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ABSTRACT 


An  algorithm  has  been  developed  for  the  detection  and  correction  of 
surface  ship  launched  expendable  bathythermograph  (XBT)  data  that  is  manually 
implemented  into  the  Sonar  In-Situ  Mode  Assessment  System  (SIMAS). 

Reliability  of  the  measured  data  is  significantly  improved  over  previous 
techniques  used  in  SIMAS  and,  with  slight  modification,  the  algorithm  can  be 
adapted  for  use  in  totally  automated  surface  ship  performance  prediction 
systems. 
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INTRODUCTION 


The  expendable  bathythermograph  (XBT)  has  proven  to  be  a  valuable  tool  in 
providing  a  description  of  the  ocean  environment  in  the  form  of  a  temperature 
vs.  depth  trace.  This  XBT  trace  is  the  source  of  the  most  significant  in-situ 
environmental  data  which  is  used  by  the  Sonar  In-Situ  Mode  Assessment  System 
(SIMAS)  and  related  system  performance  predictors  being  developed  under  the 
Acoustic  Performance  Prediction  (APP)  project  to  calculate  such  outputs  as 
detection  range  predictions  and  propagation  loss  range  functions.  It  is 
important  to  obtain  as  accurate  a  description  of  the  ocean  environment  as  is 
possible  to  achieve  maximum  reliability  of  the  sonar  performance  prediction 
products.  Due  to  the  unreliability  of  the  XBT  device,  it  is  necessary  to 
compare  the  data  from  it  with  historical  data  (which  is  the  result  of  many 
measurements  and  much  analysis)  in  order  to  determine  if  the  XBT  data  should 
be  used  at  all.  If  it  is  determined  that  the  XBT  data  is  usable,  it  will  be 
compared  to  the  historical  data  again  for  any  error  correcting  which  may  be 
necessary. 

The  purpose  of  this  memo  is  to  describe  the  techniques  used  in  the  XBT 
error  correcting  algorithm  designed  for  a  surface  ship  system  which  uses 
manually  entered  data.  The  algorithm  has  been  translated  to  a  FORTRAN  77 
computer  program  and  is  presently  being  used  in  the  version  of  the  Sonar 
In-Situ  Mode  Assessment  System  (SIMAS)  that  is  operational  on  the  VAX  11/780 
at  NUSC/NL . 

An  algorithm  has  been  designed  for  an  automated  system  with  the  intended 
use  being  in  submarine  performance  prediction  systems  (reference  A).  Using 
this  algorithm  as  a  guide  and  baseline,  changes  were  made  to  allow  the  use  of 
the  same  error  correcting  techniques  in  a  manually  operated  system  (i.e.,  a 
system  where  the  data  is  entered  at  a  terminal).  Changes  were  also  made  so 
that  the  final  product  of  the  algorithm  is  not  biased  toward  submarine 
performance  prediction  systems.  In  the  case  of  the  submarine  automated 
system,  depth-temperature  pairs  are  provided  by  the  XBT  probe  every  four 
feet.  This  would  result  in  376  depth-temperature  pairs  if  the  XBT  probe  was 
accurate  to  a  depth  of  1500  feet.  In  the  case  of  the  manually  operated 
surface  ship  system,  the  sonar  operator  must  select  the  depth-temperature 
pairs  from  the  XBT  trace  with  the  maximum  number  allowed  to  be  entered  set  at 
25.  Typically,  five  to  ten  pairs  are  sufficient. 

DESCRIPTION  OF  TESTS 


The  following  is  a  brief  discussion  of  the  tests  used  in  the  algorithm  to 
determine  if  the  XBT  data  should  be  accepted  or  rejected.  The  two  tests 
performed  on  the  XBT  data  are:  (1)  a  realistic  temperature  range  test,  and 
(2)  a  test  of  deviation  from  the  historical  data  (tolerance  envelope  test). 

(1)  The  first  test  (temperature  range  test)  is  performed  to  ensure  that 
the  XBT  data  is  within  realistic  temperature  limits.  The  range  to  define  the 
realistic  bounds  for  the  temperature  is  27°F  to  95°F.  If  more  than  half  of 
the  temperature  values  at  depths  shallower  than  1500  feet  are  outside  the 
allowable  range,  the  data  will  be  rejected.  This  test  will,  for  example, 
detect  a  near  surface  wire  break.  A  wire  break  or  similar  failure  near  the 
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surface  cannot  be  corrected.  If  the  XBT  data  fails  this  test,  the  operator 
is  given  the  following  choices: 

1  =  New  BT 

2  =  Historical  (See  References  B  -  F) 

At  this  time  it  should  be  mentioned  that  the  XBT  temperature  gradient 
extreme  test  and  modification,  which  has  been  performed  in  previous  versions 
of  the  algorithm,  has  been  removed.  There  are  three  reasons  for  this.  First, 
it  was  found  that  there  was  historical  data  which  exceeded  the  limits  being 
applied  to  the  XBT  temperature  gradients.  Second,  it  was  found  that  modifying 
these  gradients  under  certain  situations  could  alter  the  layer  depth  of  the 
XBT.  Third,  it  was  decided  that  altering  the  manually  input  XBT  temperatures 
before  comparing  the  X8T  data  against  the  historical  tolerance  envelope  to 
determine  acceptance  or  rejection  of  the  XBT  was  undesirable.  Adjustment  of 
XBT  points  to  the  historical  tolerance  envelope,  glitch  removal  and  smoothing 
as  described  in  "Description  of  the  Algorithm"  below  will  adjust  any  gradients 
which  are  truly  extreme  for  the  ocean  area  and  month. 

(2)  The  second  test  (tolerance  envelope  test)  is  a  general  examination  for 
errors  which  compares  the  XBT  data  against  the  historical  data's  tolerance 
envelope.  The  calculation  of  the  tolerance  envelope  is  based  on  the  fact  that 
the  water  temperature  varies  within  determinable  limits  about  the  historical 
data.  Since  the  historical  data  is  available  in  terms  of  sound  speed,  this 
test  will  use  the  XBT's  sound  speed  values  instead  of  temperature  values. 
Studies  show  that  the  sound  speed  at  the  surface  in  a  specific  location  varies 
less  than  +  15  ft/sec  about  the  mean  and  the  variation  tapers  off  so  there  is 
practically  no  variation  at  2500  feet.  The  tolerance  envelope  is  defined  by 
the  expression 


SS  +  (15  -  .OObD) 

where  SS  is  the  historical  sound  speed  in  ft/sec  at  depth  D  in  feet.  This 
expression  defines  the  maximum  allowable  deviation  in  ft/sec  from  the 
historical  value. 

It  was  found  that  different  operators  were  selecting  different  points  from 
the  XBT  trace  for  manual  entry  into  SIMAS.  One  operator  might  select  most  XBT 
points  in  a  region  where  the  XBT  trace  was  within  the  tolerance  envelope, 
while  another  operator  might  select  most  XBT  points  in  a  region  where  the  XBT 
trace  was  outside  of  the  tolerance  envelope.  Comparing  this  raw  XBT  data 
against  the  tolerance  envelope  could  cause  an  acceptable  XBT  to  be  rejected  or 
a  bad  XBT  to  be  accepted,  depending  on  which  points  the  operator  selected.  In 
order  to  alleviate  this  problem  and  give  equal  weight  to  all  the  selected  XBT 
data  points,  the  XBT  and  historical  sound  speeds  are  now  interpolated  for 
every  4  feet  of  depth.  One  half  the  width  of  the  historical  tolerance 
envelope  is  also  calculated  for  every  4  feet  of  depth.  These  temporary 
interpolated  values  are  not  used  in  the  merge  of  the  resultant  profile  and 
reside  in  two  single  variables  as  the  algorithm  loops  from  the  surface  to  1500 
feet  or  the  last  XBT  point  (whichever  comes  first)  with  an  increment  of  4 
feet.  One  counter  (CNT)  is  incremented  for  every  pass  through  the  loop,  and 
another  counter  (BAD)  is  incremented  every  time  the  XBT's  interpolated  sound 
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speed  falls  outside  the  tolerance  envelope  about  the  historical's  interpolated 
sound  speed.  After  leaving  this  loop  (BAD)  is  compared  to  (CNT)  and  if  more 
than  half  of  the  (CNT)  points  are  (BAD),  the  XBT  is  rejected.  If  the  XBT 
fails  the  tolerance  envelope  test  the  operator  is  given  the  following  choices: 

1  =  New  XBT  or  edit  current  XBT  (Recommended) 

2  =  New  SSP  Area  (Recommended) 

3  =  Use  historical  SSP  (Recommended) 

4  =  Force  BT  to  fit  Historical  (XBT  data  will  be  adjusted  to  use 

layer  depth  indicated  by  XBT  and  historical  data  below  layer) 

5  =  Use  XBT  exactly  as  is  (Not  recommended  because  the  XBT  has  been 

rejected  and  may  produce  unreliable  results.) 

DESCRIPTION  OF  THE  ALGORITHM 


Following  is  a  description  of  the  XBT  algorithm  which  uses  the  2  tests 
described  above. 

The  XBT  data  can  be  entered  at  the  terminal  in  metric  or  English 
temperatures  or  sound  speeds.  The  algorithm  automatically  determines  which 
form  each  data  point  was  entered  in,  converts  it  if  necessary,  and  fills  one 
array  with  english  depths,  another  array  with  english  temperatures,  and  two 
arrays  with  english  sound  speeds.  Leroy's  equation  is  used  to  derive  sound 
speed  from  temperature  or  temperature  from  sound  speed. 

The  previous,  current,  and  next  months'  historical  Sound  Speed  Profiles 
(SSPs)  are  displayed  graphically  side  by  side  (solid  curves)  with  the  XBT's 
depth-sound  speed  pairs  (X's)  overlaying  each  of  them  for  operator  comparison 
(see  figure  1).  The  operator  chooses  the  closest  matching  month  which  is  to 
be  used  for  merging  with  the  XBT.  This  is  especially  useful  if,  for  example, 
it  is  July  first  and  the  operator  isn't  sure  whether  to  use  June  or  July 
historical  data  for  comparing  the  XBT  data  against.  The  operator  is  given  the 
opportunity  to  get  a  hard  copy  of  this  graphics  display. 

Now  the  layer  depths  of  the  chosen  month's  historical  SSP  and  the  XBT's 
SSP  are  defined.  This  is  done  by  checking  the  appropriate  SSP  to  find  the 
first  sound  speed  value  that  is  less  than  the  one  preceeding  it.  Once  this 
sound  speed  value  is  found,  the  layer  depth  is  defined  as  the  depth 
corresponding  to  the  sound  speed  value  preceeding  it. 

Test  (1)  (Temperature  Range  Test)  is  performed  at  this  time.  (See 
'Description  of  Tests'  above) 

Test  (2)  (Tolerance  Envelope  Test)  is  performed  at  this  time.  (See 
'Description  of  Tests'  above) 

If  the  above  two  tests  are  passed,  the  XBT  processing  continues  as 
described  below. 

It  has  been  determined  from  the  study  described  in  reference  A  that  the 
mean  layer  values  for  the  North  Pacific,  North  Atlantic,  and  Indian  Oceans 
vary  no  greater  than  +  50  feet  61  percent  of  the  time  for  a  specific  location 
and  month.  Using  this  criteria  of  limiting  the  XBT  layer  depth  to  a  range  of 
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+  50  feet  of  the  historical  layer  depth  will  not  alter  the  final  output  of  the 
performance  prediction  system  significantly  unless  there  is  a  shallow  layer 
with  a  shallow  source.  In  this  case,  the  final  predictions  could  be  caused  to 
be  pessimistic  or  optimistic,  depending  on  whether  the  layer  was  shifted  to  a 
shallower  or  deeper  depth.  The  shifting  of  the  layer  to  a  shallower  depth  in 
the  surface  ship  application  will  cause  the  final  predictions  to  be 
pessimistic,  i.e.,  the  shallower  the  layer,  the  smaller  the  predicted  range  of 
coverage  will  be.  To  ensure  that  the  most  pessimistic  outcome  is  always 
produced,  the  following  limitation  was  put  on  the  layer  depth  check.  The  XBT 
layer  depth  is  compared  with  the  historical  layer  depth.  If  the  XBT  layer 
depth  <  =  the  historical  layer  depth  and  <  100  feet,  the  XBT  layer  depth  is 
used.  If  not,  the  XBT  layer  depth  is  again  compared  to  the  historical  layer 
depth.  If  the  XBT  layer  depth  is  within  +  50  feet  of  the  historical  layer 
depth,  the  XBT  layer  depth  is  used.  If  not,  the  XBT  layer  depth  is  modified 
to  +  50  feet  of  the  historical  layer  depth. 

The  sound  speeds  which  correspond  to  the  manually  entered  XBT  data  points 
are  now  compared  against  the  historical  tolerance  envelope.  Working  from  the 
surface,  any  points  wnich  lie  outside  the  envelope  are  moved  to  the  edge  of 
the  envelope.  If  a  point  2500  feet  or  deeper  is  encountered,  the  previous 
point  becomes  the  last  data  point.  This  is  done  so  that  the  XBT  data  can  be 
merged  smoothly  into  the  historical  data  at  2500  feet  where  the  tolerance 
envelope  has  a  value  of  zero. 

The  data  is  now  checked  below  the  layer  for  glitches,  or  spurious  changes 
in  gradients  that  are  not  indicative  of  any  actual  environmental  condition. 

It  is  impossible  to  have  a  glitch  above  the  layer  because  the  layer  depth  has 
been  defined  as  the  last  point  before  the  first  negative  gradient;  therefore, 
the  direction  of  the  gradient  above  the  layer  could  never  change  twice  as 
described  below.  The  glitch  test  compares  the  gradients  between  consecutive 
sound  speed  values.  If  the  direction  of  the  gradients  between  four 
consecutive  data  points  changes  twice,  a  glitch  is  present.  The  glitch  is 
eliminated  by  removing  the  third  data  point  of  the  four  in  question.  This 
process  is  continued  until  all  gliches  are  removed  from  the  data. 

After  the  glitches  have  been  removed,  the  data  is  smoothed  to  eliminate 
the  saw-toothed  effect  produced  by  limiting  the  data  to  the  tolerance 
envelope.  If  there  were  no  bad  data  points,  i.e.,  all  the  data  points  fell 
inside  the  tolerance  envelope,  the  data  is  not  smoothed.  A  three-point 
smoothing  routine  is  used  which  ensures  that  each  data  point  is  uniformly 
weighted.  The  layer  depth  point  will  not  be  modified  by  the  smoothing  routine. 

After  the  manually  entered  XBT  data  has  gone  through  the  above  checks  and 
possible  modifications,  it  is  again  compared  against  the  historical  tolerance 
envelope.  Working  from  the  surface,  any  points  which  lie  outside  the  envelope 
are  moved  to  the  edge  of  the  envelope.  If  a  point  2500  feet  or  deeper  is 
encountered,  the  prevous  point  becomes  the  last  data  point.  This  is  done  so 
that  the  XBT  data  can  be  merged  smoothly  into  the  historical  data  at  2500  feet 
where  the  tolerance  envelope  has  a  value  of  zero.  This  is  being  done  a  second 
time  because  the  layer  depth  check  and  modification  could  have  added  a  point 
at  2500  feet  or  deeper.  The  final  layer  depth  to  be  u^ed  by  prediction 
routines  is  determined  from  the  resultant  merged  profile  produced  in  the  next 
step. 
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Finally,  the  data  is  extended  to  2500  feet  where  the  historical  deep 
profile  can  be  appended  to  the  XBT  data  to  produce  a  continuous  profile  from 
the  surface  to  the  bottom  of  the  ocean.  The  data  is  extended  by  using  the 
following  expression. 

* 

(2500  -  QS(L) ) / (DEPDIF) ( VELD  IF)  +  VS(L) 

where:  DS ( L)  =  Historical  depth  (in  feet)  at  which  sound  speed  is 

re-calculated. 

DEPDIF  =  Depth  difference  (in  feet)  between  the  last  XBT  point 
and  2500  feet. 

VELDIF  =  Sound  speed  difference  (in  feet  per  second)  between  the 
XBT  data  and  historical  data  at  the  depth  of  the  last 
XBT  point. 

VS(L)  =  Historical  sound  speed  (in  feet  per  second)  at  the 
depth  of  the  point  at  which  sound  speed  is 
re-calculated. 

The  resultant  profile  is  now  displayed  graphically  on  the  CRT  along  with 
an  environmental  data  summary  (see  figure  2).  The  operator  is  given  the 
opportunity  to  get  a  hard  copy  of  this  graphics  display.  A  second 
environmental  summary  with  more  detail  and  no  graphics  is  always  output  to  the 
disk  and  the  line  printer  (see  figure  3). 

A  flowchart  describing  this  algorithm  is  provided  in  APPENDIX  A.  APPENDIX 
B  shows  the  logical  calling  sequence  of  the  subroutines  used  in  this 
algorithm.  The  FORTRAN  77  subroutines  are  listed  alphabetically  in  APPENDIX  C. 

SUMMARY 


Several  new  features  have  been  incorporated  into  this  version  of  the  XBT 
processing  algorithm  which  are  very  useful.  This  version  allows  the  operator 
to  use  his  judgement  by  graphically  comparing  the  XBT's  SSP  to  the  historical 
SSPs  of  the  previous,  current  and  next  month  allowing  him  to  choose  the 
historical  SSP  which  most  closely  matches  the  XBT's  SSP  for  merging  purposes. 
This  could  mean  the  difference  between  rejection  and  acceptance  of  the  XBT 
especially  if  the  current  date  is  close  to  a  month  boundary. 

The  operator  is  also  allowed  to  make  the  above  comparisons  with  the 
historical  SSP's  of  adjacent  SSP  areas  (see  figure  4).  This  allows  the 
operator  to  move  through  space  as  well  as  time  and  it  could  also  mean  the 
difference  between  rejection  and  acceptance  of  the  XBT  especially  if  the 
platform  is  operating  close  to  the  boundary  of  a  SSP  area.  These  graphical 
decision  aids  show  the  operator  how  close  the  XBT  data  is  to  the  historical 
data  and  give  him  some  leeway  in  selecting  the  best  historical  data  when 
boundary  conditions  exist. 

The  gradient  extremes  check  and  modification  has  been  removed  thereby 
eliminating  several  problems. 

The  tolerance  envelope  test  has  been  modified  to  give  equal  weight  to  all 
XBT  data  points  making  the  acceptance/rejection  of  the  XBT  more  uniform 
between  different  operator  entries  for  the  same  XBT  trace.  This  acceptance/ 
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rejection  uniformity  will  be  further  improved  when  the  surface  ship  XBT  data 
input  is  automated  thereby  eliminating  the  need  for  operators  to  select  points 
from  an  XBT  trace  for  manual  entry  into  the  computer. 
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I 
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(2)1 


EXTRACT  HISTORICAL  DATA  CEASED 
ON  OPERATOR'S  CHOICE  MADE  IN 
BLOCK  (2)1  TO  BE  USED  FOR 
TESTS  AND  MERGE. 


i 

i 

V 


1  XET  CALLS  LAYER  AND  INSERT  (.4)1 

i  i 


i  DEFINE  LAYER  DEFTH  OF  HIST- 
1  ORXCAL  DATA  AND  XET  DATA. 


[ 
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V 


XET 
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!  XET  TEMPERATURE  EXTREMES  TEST. 1 
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( 6 )  ! 
i 


i  ELIMINATE  DUPLICATE  CGNSEC- 
1  UTIVE  DEPTHS  FROM  XET  DATA . 


t 
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rr 


XET  CALLS  DUFVEL 


(7)1 


1  ELIMINATE  DUPLICATE  C0N3EC- 
1  UTIVE  SOUND  SPEEDS  FROM  XET 
!  DATA. 


i 

V 


!  XET  CALLS  XBTCHK  (3) 

i 


!  TOLERANCE  ENVELOPE  TEST. 

1  INTERPOLATE  HISTORICAL  AND  XET 
!  3 OOTID  SPEEDS  FOR  EVERY  4'  OF 
I  DEPTH.  IF  MORE  THAN  HALF  OF 
!  THE  INTERPOLATED  XET  SOUND 
!  SPEED'S  SHALLOWER  THAN  1500' 

I  ARE  OUTSIDE  OF  THE  TOLERANCE 
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!  REJECT  THE  XBT. 
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!  LAYER  DEPTH  IS  WITHIN  +-  OR  - 
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l  DEPTH,  USE  THE  XET  LAYER  DEPTH 
i  DEPTH.  IF  NOT,  MODIFY  THE 
1  XET  LAYER  DEPTH  TO  +  OR  -  50' 

!  OF  THE  HISTORICAL  LAYER  DEPTH. 
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AFPENDIX  A 


!  MOVE  ANY  MANUALLY  ENTERED  XBT 
l  POINTS  WHICH  FALL  OUTSIDE  THE 
I  HISTORICAL  TOLERANCE  ENVELOPE 
i  TO  THE  ENVELOPE.  REMOVE  THE 
1  LAST  CONSECUTIVE  GROUP  OF 
!  POINTS  WHICH  ARE  OUTSIDE  THE 
!  TOLERANCE  ENVELOPE. 


i 

i 

V 


1  XBT  CALLS  GLITCH  (11)1 

i  i 


1  IF  THERE  ARE  AT  LEAST  3  FOINTSI 
'  DEEPER  THAN  THE  XBT  LAYER  S 
!  DEPTH,  PERFORM  THE  GLITCH  TEST! 
!  AND  REMOVE  ANY  GLITCHES  BELOW  ! 
1  THE  LAYER.  ! 


1 

1 

V 

1 

XBT  CALLS  DUPDEP 

(12)  ! 

1 

1 

!  ELIMINATE  DUPLICATE  CQNSEC- 
!  UTIVE  DEPTHS  FROM  XBT  DATA. 


i 

! 

V 


1  XBT  CALLS  DUFVEL  ( 13 ) ! 

i  i 


!  ELIMINATE  DUPLICATE  CONSEC- 
!  UTIVE  SOUND  SPEEDS  FROM  THE 
!  XBT  DATA. 


i 
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!  XBT  CALLS  LAYER  AND  INSERT  (14)! 

i  I 


!  DEFINE  LAYER  DEPTH  OF  XBT  DATA! 
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!  SPEEDS  DIN  BLOCK  (3)3,  SMOOTH 
!  ALL  THE  MANUALLY  ENTERED  AND 
I  CORRECTED  XET  DATA  POINTS 
!  EXCEPT  THE  LAYER  DEPTH  POINT. 


1 

1 

V 

!  XET  CALLS  XETMQD 

i 

(16)  ! 
i 
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i 

i 

V 
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(17)  ! 
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EXTEND  THE  XET  DATA  CRESULTING! 
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SFEED  PROFILE  FROM  THE  OCEAN'S! 
SURFACE  TO  THE  OCEAN'S  BOTTOM  ! 
FOR  USE  BY  PREDICTION  ROUTINES! 
.DEFINE  THE  LAYER  DEPTH  OF  THE! 
RESULTANT  PROFILE .  ! 
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APPENDIX  C  CAN  BE  OBTAINED  FROM  THE  AUTHOR  UPON  REQUEST. 


Call: 


AUTOVON  636-440-4337 
COMMERCIAL  (203) -440-4337 


APPENDIX  B 


The  following  source  code  modules  are  shown  as  they  logically 
appear  in  the  current  version  of  the  SIMAS  ADM  XBT  ALGORITHM.  These 
modules  are  all  written  in  FORTRAN  77  and  have  each  been  documented 
with  prologue,  block  comments,  and  line  comments  in  accordance  with 
the  Acoustic  Performance  Prediction  Software  Architecture  Plan  of 
1  Nov  1981,  revised  9  Dec  1982. 
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ENVIRN 
MAP  ** 

BT 

EDITBT 
METRIC 
LEROY 
VELTMP 
LEROY 

VELTMP 
LEROY 
INSERT 
LAYER 
NOCONV 
INSERT 
ACOUS 
SVPGRF 
INSERT 
CONECT 
DRAW 
CL IPOS 
CLIPT 
INITT 
INUMBR 
TEXT 
LNTYPE 
MOVE 
OUTPUT 
TEXT 
XBT  * 

FORCST 
MAP  ** 

KEYPCH 
BT 

KSCAT 
LATLNG 
SVPRO 
SSP 

VELTMP 
LEROY 
INSERT 
LAYER 
NOCONV 
INSERT 
ACOUS 
SVPGRF 
INSERT 
CONECT 
DRAW 
CL IPOS 
CLIPT 
INITT 
INUMBR 
TEXT 
LNTYPE 
MOVE 
OUTPUT 
TEXT 
XBT  * 
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*  XBT 

LEROY 

XBTGRF 

SVPRO 

LAYER 

INSERT 

XBTERR 

ASIS 

INSERT 

METRIC 

DUPDEP 

DUPVEL 

XBTCHK 

XBTMOD 

ASIS 

INSERT 

LYRMOD 

GLITCH 

SMOOTH 
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** 


MAP 

SETOAC 

FSETUP 

OPNFIL 

SETPOS 

FLOOR 

INDX 

CRUNCH 

OPNFIL 

INDX 

GETREC 

BMOD 

CNNCT 

KMOD 

ENDl 

KMOD 

BMOD 

FNP 

END2 

KMOD 

BMOD 

FNP 

DNUT 
KMOD 
ENDl 
KMOD 
BMOD 
FNP 
END  2 
KMOD 
BMOD 
FNP 
FNP 
PDIST 
ENDl 
KMOD 
BMOD 
FNP 
END  2 
KMOD 
BMOD 
FNP 

BMOD 

GRAPH 

BMOD 

FNP 
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ACOUS 

ASIS 

BMOD 

BT 

CL IPOS 

CLIPT 

CNNCT 

CONECT 

CRUNCH 

DNUT 

DRAW 

DUPDEP 

DUPVEL 

EDITBT 

ENDl 

END  2 

ENVIRN 

FLOOR 

FNP 

FORCST 

FSETUP 

GETREC 

GLITCH 

GRAPH 

I NDX 

INITT 

INSERT 

INUMBR 

KEYPCH 

KMOD 

KSCAT 

LATLNG 

LAYER 

LEROY 

LNTYPE 

LYRMOD 

MAP 

METRIC 

MOVE 

NOCONV 

OPNFIL 

OUTPUT 

PDIST 

SETOAC 

SIMAS 

SMOOOTH 

SSP 

SVPGRF 

SVPRO 

TEXT 

VELTMP 

XBT 

XBTCHK 

XBTERR 

XBTGRF 

XBTMOD 


0001 

0002 

>003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 

0011 

0012 

0013 
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0015 

0016 

0017 

0018 

0019 

0020 

0021 

0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

>030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 

0055 

0056 

>057 

0058 

0059 


SUBROUTINE  ACOUS ( Z, V , NPT , CV , T, H , G, S , TP ) 

PROLOGUE : 

MODULE  NAME:  ACOUS 

AUTHOR:  G.  BROWN  &  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  1974  &  12/83  (FORTRAN  77) 

FUNCTION:  SUBROUTINE  ACOUS  USES  INPUT  OF  SOUND  SPEED  PROFILE  AND 
VERTEX I NG  VELOCITY  TO  COMPUTE  TWO-WAY  TRAVEL  TIME, 
HORIZONTAL  RANGE,  SPREADING  LOSS,  SLANT  RANGE,  AND  TIME 
VELOCITY  GRADIENT. 

INPUTS:  PARAMETERS  PASSED  IN. 

OUTPUTS:  PARAMETERS  PASSED  OUT. 

MODULES  CALLED:  NONE 

CALLED  BY:  ACTV26 , BBTBLS , OTHERS , NOCONV 


VARBL  SIZE  PURPOSE  TYPE  RANGE 


!  CV  VERTEX  VELOCITY  REAL *4 

!  DG  FACTOR  REAL *4 

!  DZ  DEPTH  FACTOR  REAL *4 

!  G  SPREADING  LOSS  REAL *4 

!  GJ  GRADIENT :SS  WITH  RESPECT  TO  DZ  REAL* 4 

!  H  HORIZ  RANGE  FOR  CURRENT  SPEED  REAL *4 

!  HJ  FACTOR  REAL *4 

!  J  COUNTER  INTEGER* 2 

!  JUP  NUMBER  OF  DATA  POINTS  MINUS  1  INTEGER *2 

!  NPT  NUMBER  OF  DATA  POINTS  INTEGER*2 

!  R1  FACTOR  REAL *4 

!  R1R2  FACTOR  REAL *4 

!  R2  FACTOR  REAL* 4 

!  S  SLANT  RANGE  REAL*4 

!  T  TWO-WAY  TRAVEL  TIME  REAL*4 

!  TP  TIME-VELOCITY  GRADIENT  REAL *4 

!  V  (1)  VELOCITY  OF  DEPTH/VEL  ARRAY  REAL*4 

!  VJ2  FACTOR  REAL *4 

!  Z  (1)  DEPTH  OF  DEPTH/VEL  ARRAY  REAL *4 

INTEGER* 2  J, JUP, NPT 

REAL *4  CV , DG , DZ , G , GJ , H , HJ , R1 , R1R2 , R2 , S , T , TP , V , VJ  2  ,  Z 

DIMENSION  Z(l) ,V(1) 

i - PRELIMINARIES - 

JUP=NPT-1  !  NUMBER  OF  DATA  POINTS  -  1 

T=0 .  !  INITIALIZE  2-WAY  TRAVEL  TIME 

TP=0 . 0  !  INITIALIZE  TIME/VEL  PROFILE 

H=0 .  !  INITIALIZE  HORIZ  RANGE 

G=Q .  !  INITIALIZE  SPREADING  LOSS 

S=0 .  !  INITIALIZE  SLANT  RANGE 

Rl  = (CV-V ( 1 ) ) * (CV+V ( 1 ) )  !  FACTOR 

IF  (R1.LT.0.)  R1=0 .  !  DISALLOW  NEGATIVE  VALUE 

R1=SQRT ( R1 )  !  FACTOR 

i - INTERMEDIATE  VALUES - 

DO  100  J=1,JUP  !  DO  UNTIL  #  OF  PTS  -  1 


R2= (CV-V( J+l ) ) * (CV+V( J+l ) )  l  FACTOR 

IF  (R2.LT.0.)  R2=0.  !  DISALLOW  NEGATIVE  VALUE 

R2=SQRT(R2)  !  FACTOR 

DZ=Z( J+l ) -Z( J)  !  DEPTH  FACTOR 

G J  = ( V ( J+ 1 ) - V ( J ) ) /DZ  !  GRADIENT:SS  WITH  RESPECT  TO  DZ 


c-u 


0060 
0061 
i)  0  6  2 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 

0081 

0082 


HJ  =  1 . /GJ* ( R1-R2 )  !  FACTOR 

H=H+HJ  !  HORIZ  RANGE  FOR  CURRENT  SPEED 

VJ2=1.  !  FACTOR 

IF  (R2.GT.0.)  VJ2=V ( J+l ) / (CV+R2 )  !  FACTOR 
T=T+l./GJ*ALOG( (CV+R1)/V(J)*VJ2)  !  TWO-WAY  TRAVEL  TIME 
R1R2=R1*R2  !  FACTOR 

R1=R2  !  FACTOR 

IF  (R1R2.LE.0.)  GO  TO  200  !  GO  TO  EQUATIONS  AND  EXIT 

DG=HJ/ (R1R2 )  !  FACTOR 

G=G+DG  I  SPREADING  LOSS 

TP=TP-DG  !  TIME-VELOCITY  GRADIENT 

S=S+CV/GJ* ( ACOS ( V ( J ) /CV ) -ACOS ( V( J+l ) /CV ) )  !  SLANT  RANGE 
100  CONTINUE  !  END  DO  LOOP 


j - FINAL  VALUES - 

200  T=4.*T  !  TWO-WAY  TRAVEL  TIME 

TP=4 . *TP  !  TIME-VELOCITY  GRADIENT 

H=2 . *H/3 .  >  HORIZ  RANGE;  SPREADING  LOSS 

G=10.0*ALOG10(H*2./3. *G*(CV/V(1) ) **2* (CV**2-V( 1 ) **2 ) ) 

S=2 . *S/3 . 0  !  SLANT  RANGE 


RETURN 

END 


!  RETURN  TO  CALLING  ROUTINE 
!  END  SUBROUTINE 


Command  qualifiers 

FORTRAN  /CHECK=ALL/LIST/SHOW=( INCLUDE, NOMAP)  DBA3 : [ LAFLEUR] ACOUS . F77 ; 1 

/CHECK = ( BOUNDS , OVERFLOW , UNDERFLOW ) 

/DEBUG= ( NOSYMBOLS , TRACEBACK ) 

/STANDARD3 ( NOSYNTAX , NOSOURCE_FORM ) 

/ SHOW= ( NOPREPROCESSOR , INCLUDE , NOMAP ) 

/F77  /NOG  FLOATING  /I4  /OPTIMIZE  /WARNINGS  /NOD  LINES  /NOCROSS  REFERENCE 


COMPILATION  STATISTICS 


Run  Time: 
Elapsed  Time: 
Page  Faults: 
Dynamic  Memory: 


1.63  seconds 
4.86  seconds 
348 

117  pages 


c-i.a. 


SUBROUT I NE  AS  I S ( NUMBER , DEPTH , SPEED ) 


0001 
0002 

>303  !  PROLOGUE: 

0004  !  MODULE  NAME:  ASIS 

0005  !  AUTHOR:  S.  LAFLEUR  &  W.  WACHTER,  CODE  3333,  NUSC/NLL 

0006  !  DATE:  1982  &  12/83  (FORTRAN  77) 

0007  !  FUNCTION:  SUBROUTINE  ASIS  ALLOWS  THE  OPERATOR  USE  BT  DATA 

0008  !  AS  IS. 

0009  !  INPUTS:  HARD  COPY  SELECTION,  OPERATOR  SELECTION  TO  UPDATE 

0010  !  PARAMETERS  OR  NOT.  VARIABLES  IN  COMMONS. 

0011  !  OUTPUTS:  CRT  PROMPTING  MESSAGES  TO  OPERATOR 

0012  !  MODULES  CALLED:  INSERT 

0013  !  CALLED  BY:  XBTMOD ,  XBTERR 

0014  ! 

0015  INCLUDE  ' DTV. INC ' 

0016  1  ! - DTV - 

0017  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0018  1  ! -  -  -  - 

0019  1  !  D  (25)  DEPTH  REAL *4 

0020  1  !  DD  (25)  DEPTH  REAL *4 

0021  1  !  NNBT  NUMBER  OF  BATHETHERMAL  INTEGER* 2 

0022  1  !  T  (25)  TEMPERATURE  REAL *4 

0023  1  !  TT  (25)  TEMPERATURE  REAL *4 

0024  1  !  VEL  (25)  VELOCITY  REAL *4 

0025  1  ! 

0026  1  INTEGER*2  NNBT 

0027  1  REAL*4  D , DD , T ,TT , VEL 

0028  1 

0029  1  COMMON  /DTV/  D ( 2 5 ) , T ( 25 ) , VEL ( 25 ) , DD ( 25 ) , TT ( 25 ) , NNBT 

JD30  1  ! - END  DTV - . - 

0031  INCLUDE  ’ENVN.INC’ 

0032  1  ! - ENVN - 

0033  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0034  1  ! -  -  -  - 

0035  1  !  BIO  (2)  BIOLOGICAL  BACK  SCATTERING  REAL *4  -57.  &  -47. 

0036  1  !  DLYR  LAYER  DEPTH  REAL *4 

0037  1  !  MGS  MGS  PROVINCE  INTEGER*2 

0038  1 

0039  1  REAL *4  BIO, DLYR 

0040  1  INTEGER*2  MGS 

0041  1  DATA  BIO/-57. ,-47./ 

0042  1 

0043  1  COMMON  /ENVN/  B 10(2) ,DLYR, MGS 

0044  1 

004  5  1  ! - END  ENVN - 

0046  INCLUDE  'SVP.INC' 

0047  1  ! - SVP - 

0048  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0049  1  ! -  -  -  - 

0050  1  !  BDF  BOTTOM  DEPTH  IN  FATHOMS  REAL *4 

0051  1  !  BIOP  BIOLOGICAL  BACK  SCATTERING  COEF  REAL*4 

0052  1  !  BTDATE  (9)  DATE  OF  LAST  BT  INPUT  BYTE 

0053  1  !  BTTIME  (8)  TIME  OF  LAST  BT  INPUT  BYTE 

0054  1  !  C  (50)  VELOCITY  (PAIRED  WITH  Z  FOR  SVP)  REAL *4 

0055  1  !  CC  (50)  VELOCITY  (PAIRED  WITH  ZZ  FOR  SVP)REAL*4 

°056  1  !  CS  SOUND  VELOCITY  AT  SURFACE  REAL *4 

Jb 57  1  !  DEG  TEMPERATURE  (DEG)  REAL *4  57.2957795 

0058  1  !  EL  LAYER  DEPTH  DATA 

0059  1  !  F  FREQUENCY  REAL *4 


C-2,1 


0060  1 
0061  1 
1062  1 
0063  1 

0064  1 

0065  1 

0066  1 
0067  1 

0068  1 
0069  1 

0070  1 

0071  1 

0072  1 

0073  1 

0074  1 

0075  1 

0076  1 

0077  1 

0078  1 

0079  1 

0080  1 
0081  1 
0082  1 
0083  1 

0084  1 

0085  1 

0086  1 
0087  1 

0088 
)089  1 

0090  1 

0091  1 

0092  1 

0093  1 

0094  1 

0095  1 

0096  1 

0097  1 

0098  1 

0099  1 

0100  1 
0101  1 
0102  1 
0103  1 

0104  1 

0105 
0106 
0107 
0108 
0109 
0110 
0111 
0112 
0113 
0114 
0115 
fl.16 
0117 
0118 


GRDS 

GRIDS 

REAL *4 

0.0164 

ITO 

MINIMAL  2-WAY  TRAVEL  TIME 

INTEGER*2 

MGSOP 

MGS  PROVINCE  NUMBER 

INTEGER* 2 

N 

#  OF  DEPTH/VELOCITY  PAIRS 

INTEGER*2 

NN 

#  OF  DEPTH/VELOCITY  PAIRS 

INTEGER* 2 

PI 

MATHEMATICAL  CONSTANT  PI 

REAL *4 

3.1415927 

SNDATE 

(9) 

DATE  SYS  PARMS  LAST  UPDATED 

BYTE 

SNT IME 

(8) 

TIME  SYS  PARMS  LAST  UPDTAED 

BYTE 

SYDATE 

(9) 

CURRENT  DATE  READ  FROM  SYSTEM 

BYTE 

SYT IME 

(8) 

CURRENT  TIME  READ  FROM  SYSTEM 

BYTE 

TMP 

TEMPERATURE 

REAL *4 

UMKZ 

BOTTOM  BACK  SCATTERING  COEF . 

REAL *4 

O 

• 

CO 

CN 

1 

WS 

WIND  SPEED 

REAL *4 

z 

(50) 

DEPTH  OF  POINT  OF  SOUND  SPEED 

REAL*4 

ZZ 

(50) 

DEPTH  OF  POINT  OF  SOUND  SPEED 

REAL *4 

INTEGER*2  ITO, MGSOP, N,NN 

REAL *4  BDF , BIOP , C( 50 ) ,CC(50) , CS , DEG , EL , F , GRDS 

REAL *4  PI ,  TMP ,  CJMKZ  ,  WS  ,  Z  (  50  )  ,ZZ(50) 

BYTE  SYDATE( 9 ) ,SYTIME(8) , BTDATE ( 9 ) , BTT I ME ( 8 ) 

BYTE  SND ATE ( 9  )  , SNT I ME ( 8 ) 

DATA  PI, DEG, GRDS/3. 141592 7 ,57.2957795 ,0.0164/ 

DATA  UMKZ/-28 . / 

COMMON  /SVP/  F , N , Z , C , EL , MGSOP , BDF , WS , CS , TMP , BIOP , 

'  1  UMKZ,PI , DEG, GRDS, ITO, ZZ ,CC,NN , 

2  SYDATE , SYT IME , BTDATE , BTTIME , SNDATE , SNT IME 

- SVP-END - 

INCLUDE  ’ SVP1 . INC ’ 

- SVP1 - 

VARBL  SIZE  PURPOSE  TYPE  RANGE 


BUFFER  (224)  HISTORICAL  DATA  FILE  BUFFER  REAL *4 

DS  (30)  HISTORICAL  DEPTH  REAL *4 

J20  #  OF  DEEP  OCEAN  DEPTH/VEL  PAIRS  INTEGER* 2 

NS  TOTAL  #  OF  PAIRS  IN  HISTORICAL  INTEGER* 2 

NSN  MONTH  NUMBER  (1=JAN.,ETC)  INTEGER* 2  1  TO  12 

SLNTY  SALINITY  REAL *4 

VS  (30)  HISTORICAL  VELOCITY  REAL  *  4 


REAL *4  BUFFER, DS, SLNTY, VS 

INTEGER* 2  J 20, NSN, NS 

COMMON  /SVP1/  J20,BUFFER(224) , NSN, SLNTY, DS(30) ,VS(30) , NS 
- END  SVP1 - 

VARBL  SIZE  PURPOSE  TYPE  RANGE 


DEPDIF 

DEPTH  (25) 

ICNT 

INDEXH 

J 

L 

M 

NU 

NUMBER 
SPEED  (25) 
VELD IF 


DIFFERNECE  IN  DEPTH 

DEPTH 

COUNTER 

INDEX  OF  HISTORICAL  POINT 

COUNTER 

COUNTER 

COUNTER 

SVP  INDEX 

NUMBER  OF  BT  POINTS 
SVP  INDEX 

DIFFERENCE  IN  VELOCITY 


REAL*  4 
REAL *4 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
INTEGER *2 
INTEGER* 2 
REAL*4 
REAL *4 


ea.x 


0119 

i 

« 

0120 

i  *  *  * 

• 

VARIABLES  NOT  LISTED  HERE  SHOULD 

APPEAR  IN  COMMON  *** 

YL  2 1 

0122 

INTEGER*2  ICNT, INDEXH, J,L,M,NU 

,  NUMBER 

0123 

REAL *4  DEPDIF, DEPTH, SPEED, VELDIF 

0124 

DIMENSION  DEPTH (25), SPEED (25) 

0125 

0126 

i - 

- GET  AND  STORE  EXISTING  DATA  "AS 

0127 

CALL  INSERT ( NS, DS, VS, DEPTH ( NUMBER ) ,NU)  !  GET  SVP  FOR  HISTORICAL 

0128 

ICNT=0 

!  INITIALIZE  ICNT 

0129 

DO  100  J-l, NUMBER 

!  PUT  BT  INTO  PROFILE  "AS  IS" 

0130 

I CNT= ICNT+1 

!  INCREASE  COUNT 

0131 

Z( ICNT)=DEPTH(J) 

!  STORE  DEPTH 

0132 

C( ICNT ) =SPEED ( J ) 

!  STORE  VELOCITY 

0133 

100 

CONTINUE 

!  CONTINUE 

0134 

DEPDIF  =  2500. -DEPTH ( NUMBER) 

!  DIFFERENCE  IN  DEPTH 

0135 

VELD I F=SPEED ( NUMBER ) -VS ( NU ) 

!  DIFFERENCE  IN  SOUND  SPEED 

0136 

0137 

! 

- FIND 

INDEX  OF  HIST  PT  DEEPER  THAN  LAST 

0138 

DO  200  INDEXH=1 ,NS 

!  DO  FOR  NUMBER  OF  HIST  VALUES 

0139 

IF(DS( INDEXH) .GT. DEPTH (NUMBER) +5 J  GOTO  250  !  EXIT  LOOP 

0140 

200 

CONTINUE 

!  END  DO  LOOP 

0141 

INDEXH=NS 

!  SET  HISTORICAL  INDEX 

0142 

250 

DO  300  L= INDEXH, NS 

!  ADJUST  HIST  PTS  FROM  LAST 

0143 

IF(DS(L) .GT.2500. )  GOTO  350 

!  BT  PT  TO  2500'  TO  FIT  BT 

0144 

ICNT= ICNT+ 1 

!  INCREASE  COUNT 

0145 

Z( ICNT)=DS(L) 

!  STORE  DEPTH 

0146 

C( ICNT)=(2500-DS(L) )/DEPDIF*VELDIF+VS(L) !  STORE  VELOCITY 

0147 

300 

CONTINUE 

!  END  DO  LOOP 

)48 

GO  TO  500 

!  RESET  TO  AVOID  LOOP  400 

0150 

! 

- pUT  HIST  BELOW  2500'  INTO  RESULTANT  PROFILE 

0151 

350 

DO  400  M=L , NS 

!  DO  FOR  ALL  HIST  VALUES 

0152 

I CNT= ICNT+1 

!  INCREMENT  COUNTER 

0153 

Z( ICNT) =DS (M) 

!  STORE  DEPTH  AS  IS 

0154 

C( ICNT) =VS (M) 

!  STORE  VELOCITY  AS  IS 

0155 

400 

CONTINUE 

!  END  DO  LOOP 

0156 

500 

N= ICNT 

!  SET  NUMBER  OF  BT  POINTS 

0157 

RETURN 

!  RETURN  TO  CALLING  ROUTINE 

0158 

END 

!  END  SUBROUTINE 

M.3 


0001 

0002 

)003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 

0011 

0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 

0021 

0022 

0023 

0024 

0025 

0026 

0027 

0028 


REAL *4  FUNCTION  BMOD ( A , B ) 

PROLOGUE: 

MODULE  NAME:  BMOD 

AUTHOR:  E.  PETR IDES  &  P.  FRAGEORGI A  OF  SYSCON,  INC 

RECODED:  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  1982  &  6/84  (FORTRAN  77) 

FUNCTION:  THIS  FUNCTION  IS  DESIGNED  TO  CALCULATE  THE  CLOCK 

ARITHMETIC  MODULO  VALUE  FROM  THE  TWO  PARAMETERS  PASSED. 
INPUTS:  TWO  PARAMETERS  PASSED  IN 
OUTPUTS:  CLOCK  ARITHMETIC  MODULO  VALUE 
MODULES  CALLED:  NONE 

CALLED  BY:  CRUNCH,  END1 ,  END2 ,  GETREC,  GRAPH 

VARBL  SIZE  PURPOSE  TYPE  RANGE 


A  THE  MODULO  DIVISOR  (REAL* 4) 

B  THE  CLOCK  ARITHMATIC  MODULUS  ( INTEGER*2 ) 

REAL *4  A 
INTEGER* 2  B 

BMOD= AMOD ( A , FLOAT 1(B))  !  GET  REMAINDER  FROM  A/B 

IF  ( A*B . LT . 0 . )  BMOD=B+BMOD  !  IF  A  OR  B  <0,  ADD  MODULUS 

IF  (B.EQ.0)  BMOD=0.0  !  IF  DIVISION  BY  0,  SET  TO  0 

RETURN  !  RETURN  TO  CALLING  ROUTINE 

END  !  END  SUBROUTINE 


C-3vl 


0001 

0002 

>003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 

0011 

0012 

0013 

0014 

0015 


1 

1 

1 


SUBROUTINE  BT ( INSSP , NBT) 

PROLOGUE: 

MODULE  NAME:  BT 

AUTHOR:  G.  BROWN  &  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  1974  &  12/83  (FORTRAN  77) 

FUNCTION:  SUBROUTINE  BT  IS  USED  FOR  MANUAL  ENTRY  OF  BT  DATA 
(DEPTH  AND  TEMPERATURE  VALUES). 

INPUTS:  OPERATOR  INPUT  OF  DATA.  VARIABLES  IN  COMMONS. 

OUTPUTS:  CRT  PROMPTING  MESSAGES  TO  OPERATOR. 

MODULES  CALLED:  ED I TBT , METR I C 
CALLED  BY:  ENVIRN 


INCLUDE  ' DTV . INC ' 


-DTV- 


0016 

1 

j 

VARBL 

SIZE 

PURPOSE 

TYPE 

0017 

1 

i 

- - 

— 

0018 

1 

j 

D 

(25) 

DEPTH 

REAL*4 

0019 

1 

j 

DD 

(25) 

DEPTH 

REAL*4 

0020 

1 

1 

NNBT 

NUMBER  OF  BATHETHERMAL 

INTEGER 

0021 

1 

i 

T 

(25) 

TEMPERATURE 

REAL*4 

0022 

1 

1 

TT 

(25) 

TEMPERATURE 

REAL*4 

0023 

1 

j 

VEL 

(25) 

VELOCITY 

REAL*4 

0024 

1 

1 

0025 

1 

INTEGER* 2 

NNBT 

0026 

1 

REAL *4  D, 

DD,T,TT, VEL 

RANGE 


COMMON  /DTV/ 


D(25) , T ( 2  5 ) , VEL ( 2  5 ) , DD ( 2  5 ) , TT ( 2  5 ) , NNBT 

- END  DTV - 

INCLUDE  'S VP. INC' 

- SVP - 


0032 

0033 

1 

1 

| 

| 

VARBL 

SIZE 

PURPOSE 

TYPE 

RANGE 

0034 

1 

i 

BDF 

BOTTOM  DEPTH  IN  FATHOMS 

REAL *4 

0035 

1 

1 

BIOP 

BIOLOGICAL  BACK  SCATTERING  COEF 

REAL *4 

0036 

1 

I 

BTDATE 

(9) 

DATE  OF  LAST  BT  INPUT 

BYTE 

0037 

1 

j 

BTTIME 

(8) 

TIME  OF  LAST  BT  INPUT 

BYTE 

0038 

1 

1 

C 

(50) 

VELOCITY  (PAIRED  WITH  Z  FOR  SVP) 

REAL *4 

0039 

1 

j 

cc 

(50) 

VELOCITY  (PAIRED  WITH  ZZ  FOR  SVP 

) REAL *4 

0040 

1 

1 

cs 

SOUND  VELOCITY  AT  SURFACE 

REAL *4 

0041 

1 

| 

DEG 

TEMPERATURE  (DEG) 

REAL *4 

57.2957795 

0042 

1 

i 

EL 

LAYER  DEPTH 

DATA 

0043 

1 

i 

F 

FREQUENCY 

REAL *4 

0044 

1 

i 

• 

GRDS 

GRIDS 

REAL *4 

0.0164 

0045 

1 

| 

I  TO 

MINIMAL  2-WAY  TRAVEL  TIME 

INTEGER*2 

0046 

1 

i 

MGSOP 

MGS  PROVINCE  NUMBER 

INTEGER*2 

0047 

1 

1 

N 

#  OF  DEPTH/VELOCITY  PAIRS 

INTEGER*2 

0048 

1 

| 

NN 

#  OF  DEPTH/VELOCITY  PAIRS 

INTEGER* 2 

0049 

1 

t 

PI 

MATHEMATICAL  CONSTANT  PI 

REAL*4 

3.1415927 

0050 

1 

i 

SNDATE 

(9) 

DATE  SYS  PARMS  LAST  UPDATED 

BYTE 

0051 

1 

j 

SNTIME 

(8) 

TIME  SYS  PARMS  LAST  UPDTAED 

BYTE 

0052 

1 

; 

SYDATE 

(9) 

CURRENT  DATE  READ  FROM  SYSTEM 

BYTE 

0053 

1 

1 

SYTIME 

(8) 

CURRENT  TIME  READ  FROM  SYSTEM 

BYTE 

0054 

1 

i 

TMP 

TEMPERATURE 

REAL *4 

0055 

1 

| 

UMKZ 

BOTTOM  BACK  SCATTERING  COEF. 

REAL* 4 

-28.0 

0056 

1 

! 

WS 

WIND  SPEED 

REAL *4 

)057 

1 

j 

Z 

(50) 

DEPTH  OF  POINT  OF  SOUND  SPEED 

REAL *4 

0058 

1 

i 

» 

ZZ 

(50) 

DEPTH  OF  POINT  OF  SOUND  SPEED 

REAL *4 

0059 


c-4.1 


0060  1  INTEGER* 2  ITO,MGSOP,N,NN 

0061  1  REAL *4  BDF , BIOP ,C < 50 ) , CC ( 50 ) ,CS , DEG , EL , F ,GRDS 

)062  1  REAL*4  P I , TMP,UMKZ , WS , Z ( 50 ) , ZZ ( 50 ) 

0063  1  BYTE  SYDATE( 9 ) , SYTIME ( 8 ) , BTDATE( 9 ) , BTTIME ( 8 ) 

0064  1  BYTE  SNDATE ( 9 ) , SNTIME ( 8 ) 

0065  1  DATA  PI , DEG , GRDS/3 . 14 15927 , 57 . 2957795 , 0 . 0 164/ 

0066  1  DATA  UMKZ/-28./ 

0067  1 

0068  1  COMMON  /SVP/  F,N,Z,C,EL,MGSOP,BDF, WS,CS,TMP,BIOP, 

0069  1  1  UMKZ , P I , DEG , GRDS , I TO , ZZ , CC , NN , 

0070  1  2  SYDATE,SYTIME,BTDATE, BTTIME, SNDATE, SNTIME 

0071  1  ! - SVP -END - 

0072  INCLUDE  'SVP1.INC' 

0073  1  ! - SVP1 - 

0074  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0075  1  ! -  -  -  - 

0076  1  !  BUFFER  (224)  HISTORICAL  DATA  FILE  BUFFER  REAL *4 

0077  1  !  DS  (30)  HISTORICAL  DEPTH  REAL* 4 

0078  1  !  J20  #  OF  DEEP  OCEAN  DEPTH/VEL  PAIRS  INTEGER *2 

0079  1  !  NS  TOTAL  #  OF  PAIRS  IN  HISTORICAL  INTEGER*2 

0080  1  !  NSN  MONTH  NUMBER  (WAN.,  ETC)  INTEGER*  2  1  TO  12 

0081  1  !  SLNTY  SALINITY  REAL  *  4 

0082  1  !  VS  (30)  HISTORICAL  VELOCITY  REAL *4 

0083  1 

0084  1  REAL *4  BUFFER, DS , SLNTY , VS 

0085  1  INTEGER *2  J20,NSN,NS 

0086  1 

0087  1  COMMON  /SVP1/  J20 , BUFFER( 224 ) , NSN, SLNTY, DS(30) ,VS(30) , NS 

0088  1  ! - END  SVP1 - 

)08  9  ! 

0090  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0091  !  - -  -  -  - 

0092  !  I  COUNTER  INTEGER* 2 

0093  !  INSSP  INPUTTED  SSP  INTEGER*2 

0094  !  I ERROR  ERROR  FLAG  FOR  METRIC  INTEGER* 2 

0095  !  J  COUNTER  INTEGER* 2 

0096  !  JANS  OPERATOR  RESPONSE  FOR  LAST  BT  INTEGER* 2 

0097  !  L  OPERATOR  RESPONSE  FOR  EDIT  BT  INTEGER*2  Y  OR  N 

0098  !  NBT  NUMBER  OF  BT  POINTS  INTEGER *2 

0099  ! 

0100  !  ***  VARIABLES  NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMONS  *** 

0101 

0102  INTEGER*2  I , IERROR, INSSP, J , JANS , L , NBT 

0103 

0104  10  IERROR  =  0  !  INITIALIZE  ERROR  FLAG 

0105  CALL  ICLR  !  CLEAR  SCREEN 

0106  WRITE( 5 , 2000 )  !  USE  LAST  BT  PROMPT 

0107  READ (5,1050)  JANS  !  OPERATOR  RESPONSE 

0108  IF( JANS . EQ. ' Y ' )  THEN  !  IF  TRUE,  USE  LAST  BT 

0109  DO  250  1=1, NNBT  !  USE  BT  SAVED 

0110  D ( I ) =DD( I )  !  STORE  DEPTH 

0111  T(l)=TT(i)  !  STORE  TEMPERARURE 

0112  250  CONTINUE  !  END  DO  LOOP 

0113  NBT=NNBT  !  NUMBER  OF  BT  POINTS 

0114  GOTO  75  !  GO  TO  OUTPUT 

0115  END  IF  !  END  IF  BLOCK 

Jll6  CALL  ICLR  !  CLEAR  SCREEN 

0117  WRITE ( 5 , 2200 )  !  INPUT  BT 

0118  DO  50  J=1 , 25  !  DO  25  TIMES 


c-v.  z. 


0119 

0120 

)121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

)l48 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 


50 

60 


75 


100 


WRITE(5, 1310)  J 
READ (5,1300)  D(J) fT(J) 

I F ( J . GT . 1 . AND . D ( J ) .LE.l 
CONTINUE 
J=26 
NBT=J-1 

CALL  DATE (BTD ATE) 

CALL  TIME(BTTIME) 

WRITE { 5,1380) 

WRITE( 5,1400) 

WRITE( 5,1420)  (I,D(I),T(I 
WRITE( 5 , 1500 ) 

READ (5,1050)  L 
IF(L.EQ.'Y')  CALL  EDITBT( 
DO  100  1=1, NBT 
DD(I)-D( I) 

TT( I )-T( I ) 

CONTINUE 

NNBT=NBT 

CALL  METRIC ( INSSP,D,T, NBT 
I F ( I ERROR . EQ . 1 )  GO  TO  10 
RETURN 


WRITE  LOOP  COUNTER 
READ  DEPTH  &  TEMP 
.  )GO  TO  60  !  CHECK  FOR  LAST  ENTRY 
END  DO  LOOP 
SET  COUNTER  TO  26 
#  OF  BT  =  COUNTER  -  1 
GET  DATE 
GET  TIME 

INPUT  DATA  TITLE  PROMPT 
PARAMETER  TITLES 
), 1=1, NBT)  !  DEPTH  AND  TEMP  OR  SS 

CHECK  ENTRIES  FOR  ERRORS 
EDIT  DATA  RESPONSE 
INSSP , NBT , D, T)  !  CORRECT  BT  DATA 
SAVE  BT 
STORE  DEPTH 
STORE  TEMPERATURE 
END  DO  LOOP 
NUMBER  OF  BT  POINTS 
,  Z,C,SLNTY,VS( 1 ) , IERROR)  !  METRIC  CALC 
[  ERROR  IN  DATA  INPUT 
!  RETURN  TO  CALLING  ROUTINE 


! - FORMAT  STATEMENTS - 

1050  FORMAT ( A1 ) 

1300  FORMAT (2F10. 2) 

1310  FORMAT (T5 , 1 5 , T22 , '***** ,T32,$) 

1380  FORMAT (1H  /T2 6 OPERATOR  INPUT  DATA') 

1400  FORMAT ( //T2  2 , ’NO. '  ,T32, ’DEPTH’  ,T42, 'TEMP' 

1  /T43, ' OR' /T42 , ' SOUND '/T42, 'SPEED'/) 

1420  FORMAT ( T2 3 , 1 2 ,T32 , F7 . 1 ,T42 , F6 . 1 ) 

1500  FORMAT (1H0/1H$,4X, 'DO  YOU  WISH  TO  EDIT  THE  DATA?  YES  OR  NO  ’, 

1  T60 , '  ' ) 

2000  FORMAT ('  DO  YOU  WANT  TO  USE  THE  LAST  BT?  ’,$) 

2200  FORMAT ( T20 , 'ENTER  BT  IN  METRIC  AND/OR  ENGLISH  UNITS' 

1  '  (25  POINTS  MAX)' 

2  /T9, ' (TEMPERATURES  AND  SOUND  SPEEDS  MAY  BE  MIXED)' 

3  /T9 , ' ( AN  EXTRA  (CR)  TERMINATES  ENTRIES)' 

4  //T32 , 'DEPTH' ,T42, 'TEMP'/T43, 'OR'/T42, 'SOUND' 

5  /T42, 'SPEED' ) 

END 


c- V.3 


0001 
0002 
>003 
0004 
0005 
0006 
0007 
0008 
0009 
0010 
0011 
0012 
0013 
0014 
0015 
0016 
0017 
0018 
0019 
0020 
0021 
0022 
0023 
0024 
0025 
0026 
0027 
0028 
0029 
)o  3  0 
0031 


0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 

0055 

0056 

)057 

0058 

0059 


SUBROUTINE  CLIPOS ( IX , I Y , I , LI ) 

PROLOGUE : 

MODULE  NAME:  CLIPOS 

AUTHOR:  J.  CASCIO,  W.  WACHTER( FORTRAN  77),  NUSC/NL,  CODE  3333 

DATE:  1981  &  9/84  (FORTRAN  77) 

FUNCTION:  THIS  SUBROUTINE  IS  DESIGNED  TO  SEE  IF  THE  IX  OR  IY 
CURSOR  POSITION  IS  IN  THE  CLIPPED  AREA  AND  IF  OUT 
FIND  OUT  WHAT  QUADRANT  THE  CURSOR  IS  IN. 

INPUTS:  CURSOR  POSITION 

OUTPUTS:  QUADRANT  CURSOR  IS  IN  IF  OUT  OF  CLIP 

MODULES  CALLED:  NONE 

CALLED  BY:  DRAW,  PLUS,  POINT,  SBOX 

NOTE:  THE  NEGATIVE  NUMBERS  TELL  THE  CALLING  PROGRAM  THE  VECTOR  IS 
CORNER. 


IN  A 


\ 


\  -4 
-1  \ 


\ 


7 


/ 


■i  / 

/  -3 


PLOTTED 

0 


/ 


-4  / 
/  -2 


/ 


\  -2 
•3  \ 


UU  J  c 

0033 

J. 

1 

j 

VARBL 

SIZE 

0034 

1 

| 

— 

0035 

1 

i 

I  CL  IP 

(4) 

0036 

1 

i 

• 

ISCLIP 

0037 

1 

i 

LENX 

0038 

1 

! 

LENY 

0039 

1 

J 

MAXX 

0040 

1 

j 

MAXY 

0041 

1 

i 

MINX 

0042 

1 

i 

MINY 

INCLUDE  'SCREEN. INC' 


PURPOSE 


\ 


-SCREEN- 


CLIP  BOUNDARIES 
CLIPPING  FLAG 

LENGTH  OF  X  GRAPHICS  BOUNDARY 
LENGTH  OF  X  GRAPHICS  BOUNDARY 
MAXIMUM  X  GRAPHICS  BOUNDARY 
MAXIMUM  Y  GRAPHICS  BOUNDARY 
MINIMUM  X  GRAPHICS  BOUNDARY 
MINIMUM  Y  GRAPHICS  BOUNDARY 


TYPE 

I NT EGER *2 
LOG  I CAL *2 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
INTEGER*2 
INTEGER* 2 
INTEGER*2 


RANGE 


TRUE  FALSE 


1 

1 

1 

1 

1 

1 

1 


INTEGER* 2  I CLIP, LENX , LENY 
INTEGER *2  MAXX , MAX Y , M I NX , M I NY 
LOG I CAL *2  ISCLIP 

COMMON  /SCREEN/M I NX, MAXX, MI NY, MAXY, LENX, LENY, ICLIP(4) , ISCLIP 
- SCREEN  END - 


VARBL  SIZE  PURPOSE 


TYPE 


RANGE 


I 

TMP 

IX 

IY 

L 

LI 

QUAD1 


(5) 

(4) 


LOOP  COUNTER 

FACTOR  IN  QUADl  AND  QUAD 2  EQUATIONS 
CURSOR  X  COORDINATE 
CURSOR  Y  COORDINATE 
COORDINATES  IN  OR  OUT  OF  CLIP  BOUNDARY  LOG I CAL *2 
STORE  POINTS  OUT  OF  CLIP  AREA  LOG I CAL *2 

QUADRANT  INTEGER* 2 


INTEGER*2 
INTEGER* 2 
INTEGER*2 
INTEGER* 2 


c-5 :/ 


0060 
0061 
)062 
0063 
0064 
0065 
0066 
0067 
0068 
0069 
0070 
0071 
0072 
0073 
0074 
0075 
0076 
0077 
0078 
0079 
0080 
0081 
0082 
0083 
0084 
0085 
0086 
0087 
0088 
)o  8  9 


!  QUAD2  QUADRANT  INTEGER* 2 

i 

INTEGER* 2  I , IX , I Y , QUADl , QUAD2 
LOG I CAL *2  L( 5 ) , LI ( 4 ) 

REAL *4  TMP 


1 


3 

4 


L(1)»(IX.LT. ICLIP(l) ) 
L(2)=(IX.GT. ICLIP(2) ) 

L(3)=( IY.LT. ICLIP ( 3 ) ) 

L ( 4 ) = ( I Y . GT . ICLIP( 4 ) ) 
L(5)=L(1)+L(2)+L(3)+L(4) 

DO  1  1=1,4 
L1(I)-L(I) 

CONTINUE 

IF  ( L ( 5 ) . EQ . - 2 )  THEN 

TMP= ( ICLIP ( 1) -ICLIP( 2 ) ) *1 
QUAD1=SIGN ( 1 . , ( 1 . * ICLIP ( 3 
QUAD2=SIGN( 1 . , (l.*ICLIP(4 
L(4)=( ( QUADl. EQ.-l)  .AND. 
L(3)=( (QUADl. EQ.l)  .AND. 
L(2)=( (QUADl. GE.O)  .AND. 
L(l)=( (QUADl. LE.O)  .AND. 
END  IF 
DO  3  1=1,4 

IF  ( L ( I ) )  GOTO  4 
CONTINUE 
1  =  0 

IF  ( L ( 5 ) . EQ . - 2 )  I=-I 

RETURN 

END 


)-ICLIP(4) 
)-ICLIP( 3 ) 
(QUAD2.LE 
( QUAD2 . GE . 
( QUAD2 . EQ . 
(QUAD2.EQ. 

| 

I 

i 

i 

i 

i 

i 


X  COORDINATE  INSIDE  CLIP? 

X  COORDINATE  INSIDE  CLIP? 

Y  COORDINATE  INSIDE  CLIP? 

Y  COORDINATE  INSIDE  CLIP? 
TRUE  IF  ALL  INSIDE 

DO  FOUR  TIMES 
STORE  POINT  OUTSIDE  CLIP 
END  DO  LOOP 
CURSOR  IN  A  CORNER 
FACTOR  IN  EQUATIONS 
)*( IX- ICLIP (1) )/TMP+ICLIP( 3 
)  *( IX- ICLIP ( 1 ) )/TMP+ ICLIP ( 4 


.  0 ) )  !  CHECK  THE  EXACT  QUA 

0))  !  BY  CALCULATING  TH 

-D)  !  OF  THE  DIAGONAL  L 

1))  !  EXTENDING  FROM  OP 

!  CORNERS  OF  THE  CL 

DO  FOUR  TIMES 
POINT  IS  OUT  AT  L(I) 

END  DO  LOOP 

1=0  IF  IT  IS  WITHIN  THE  PL 
SET  I  TO  NEGATIVE  IF  IN  CO 
RETURN  TO  CALLING  ROUTINE 
END  SUBROUTINE 


C-T.2. 


0001 

0002 

)003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 

0011 

0012 

0013 

0014 

0015 

0016 

0017 

0018 


)030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 

0055 

0056 

>057 

0058 

0059 


1 

1 

1 

1 

1 

1 

1 


SUBROUTINE  CLIPT( 1X1 , I Y1 , 1X2 , I Y2 , I , J ) 

PROLOGUE : 

MODULE  NAME:  CLIPT 

AUTHOR:  J.  CASCIO,  W.  WACHTER ( FORTRAN  77),  NUSC/NL,  CODE  3333 
DATE:  1981  &  9/84  (FORTRAN  77) 

FUNCTION:  THIS  SUBROUTINE  IS  DESIGNED  TO  SET  UP  PSUEDO- POINTS 
FOR  DRWABS  WHICH  WILL  SHOW  UP  IN  THE  CLIP  AREA.  THE 
PURPOSE  OF  CLIPT  IS  TO  PREVENT  VECTORS  FROM  BEING  DRAWN 
OUT  OF  THE  CLIP  BOUNDARY  WHILE  ALLOWING  THE  BEAM  POSITION 
TO  BE  UPDATED  ACROSS  CLIP  BOUNDARIES  TO  THE  CURRENT  BEAM 
POSITION. 

INPUTS:  CLIP  BOUNDARIES 
OUTPUTS:  UPDATED  BEAM  POSITION 
MODULES  CALLED:  NONE 
CALLED  BY:  DRAW 


I NCLUDE  ' SCREEN .INC' 


UU13 

0020 

X 

1 

f 

VARBL 

SIZE 

0021 

1 

I 

— 

0022 

1 

1 

ICLIP 

(4) 

0023 

1 

1 

ISCLIP 

0024 

1 

1 

LENX 

0025 

1 

I 

LENY 

0026 

1 

1 

• 

MAXX 

0027 

1 

1 

• 

MAXY 

0028 

1 

1 

• 

MINX 

0029 

1 

1 

MINY 

-SCREEN- 


PURPOSE 


TRUE  FALSE 


CLIP  BOUNDARIES 
CLIPPING  FLAG 

LENGTH  OF  X  GRAPHICS  BOUNDARY 
LENGTH  OF  X  GRAPHICS  BOUNDARY 
MAXIMUM  X  GRAPHICS  BOUNDARY 
MAXIMUM  Y  GRAPHICS  BOUNDARY 
MINIMUM  X  GRAPHICS  BOUNDARY 
MINIMUM  Y  GRAPHICS  BOUNDARY 

INTEGER* 2  ICLIP , LENX , LENY 
INTEGER* 2  MAXX , MAX Y , M I NX , M I NY 
INTEGER* 2  ISCLIP 

COMMON  /SCREEN/M I NX , MAXX , M I NY , MAX Y , LENX , LENY , I CL I P ( 4 ) , I SCL I P 
- SCREEN  END - 


TYPE 

INTEGER* 2 
INTEGER* 2 
INTEGER*2 
INTEGER* 2 
INTEGER* 2 
INTEGER*2 
INTEGER* 2 
INTEGER* 2 


RANGE 


VARBL  SIZE  PURPOSE 


TYPE 


RANGE 


I 

IDRWX1 

IDRWX2 

IDRWY1 

I DRW Y 2 

IPT 

1X1 

1X2 

IXPT 

I YPT 

IY1 

IY2 

J 


PREVIOUS 
STARTING 
ENDING  X 
STARTING 
ENDING  Y 


BEAM  POSITION  INTEGER* 2 

X  COORDINATE  CLIPPED  INTEGER* 2 

COORDINATE  CLIPPED  INTEGER *2 

Y  COORDINATE  CLIPPED  INTEGER*2 

COORDINATE  CLIPPED  INTEGER* 2 

ARRAY  POINTER  INTEGER* 2 

X  COORD  OF  PREVIOUS  BEAM  POSIT  FUNCT IO ININTEGER* 2 
COORD  OF  CURRENT  BEAM  POSIT  FUNCTION  INTEGER* 2 
COORDINATE  FOR  SLOPE  CALCULATION 
FOR  SLOPE  CALCULATION 
OF  PREVIOUS  BEAM  POSITION 
OF  CURRENT  BEAM  POSITION 


COORDINATE 

COORDINATE 

COORDINATE 


CURRENT  BEAM  POSITION 


INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
INTEGER*2 
INTEGER* 2 


INTEGER*2  I , IDRWX1 , IDRWX2 , IDRWY1 , I DRW Y 2 , IPT , 1X1 , 1X2 
INTEGER*2  IXPT, IYPT, IY1 , IY2 , J 


- FUNCTIONS  TO  DETERMINE  THE  S 

IXPT( IPT) =1X1+ INI NT ( ( FLOAT I ( ICLIP ( IPT) ) -FLOATI ( IY1 ) ) * (FLOATI ( 1X2 
*  FLOATI ( 1X1) )/( FLOATI ( IY2) -FLOATI ( IY1) ) ) 


c-c.i 


0060  IYPT( IPT)=IY1+ININT( ( FLOAT I ( ICLIP( IPT) )-FLOATI ( 1X1 ) ) *(FLOATI ( XY2 

0061  *  FLOAT I ( IY1 ) )/( FLOAT I ( 1X2 ) -FLOATI ( 1X1 ) ) ) 

)062 

0063  ! - PRELIMINARIES - 

0064  IF  (I+J.EQ.O)  THEN  !  NO  CLIPPING  NEEDED 

0065  TYPE  1  !  TYPE  ONE 

0066  GO  TO  999  !  RETURN  TO  CALLING  ROUTINE 

0067  END  IF  !  END  IF  BLOCK 

0068  IDRWX1=IX1  !  STARTING  X  COORDINATE 

0069  IDRWY1= IY1  !  STARTING  Y  COORDINATE 

0070  IDRWX2=IX2  !  ENDING  X  COORDINATE 

0071  IDRWY2=IY2  !  ENDING  Y  COORDINATE 

0072 

0073  ! - CLIP  THE  PREVIOUS  END - 

0074  IF  (I.NE.0)  THEN  !  NOT  WITHIN  CLIP  BOUNDARIES 

0075  IF  (I.LE.2)  THEN  !  2 , 1 , -1 , -2 , -3 , -4 

0076  IDRWX1= ICLIP ( I )  !  CLIP  STARTING  X  COORDINATE 

0077  IF  (IX1.NE.IX2)  IDRWY1= I YPT ( I )  !  CLIP  STARTING  Y  COORDINATE 

0078  ELSE  !  3,4 

0079  IF  (IY1.NE.IY2)  IDRWXl= IXPT ( I )  !  CLIP  STARTING  X  COORDINATE 

Q080  IDRWY1=ICLIP( I )  !  CLIP  STARTING  Y  COORDINATE 

0081  END  IF  !  END  IF  BLOCK 

0082  END  IF  !  END  IF  BLOCK 

0083 

0084  ! - CLIP  THE  CURRENT  END - 

0085  IF  (J.NE.0)  THEN  !  NOT  WITHIN  CLIP  BOUNDARIES 

0086  IF  (J.LE.2)  THEN  !  2 , 1 , 0 , -1 , -2 , -3  , -4 

0087  IDRWX2= ICLIP (J )  !  CLIP  ENDING  X  COORDINATE 

0088  IF  (IX1.NE.IX2)  IDRWY2=IYPT(J)  !  CLIP  ENDING  Y  COORDINATE 

)089  ELSE  !  3,4 

0090  IF  (IY1.NE.IY2)  IDRWX2=IXPT( J)  !  CLIP  ENDING  X  COORDINATE 

0091  I DRWY2  =  I CL I P ( J )  !  CLIP  ENDING  Y  COORDINATE 

0092  END  IF  !  END  IF  BLOCK 

0093  END  IF  !  END  IF  BLOCK 

0094  IX1=IDRWX1  !  STARTING  X  COORDINATE 

0095  I Yl= IDRWY1  !  STARTING  Y  COORDINATE 

0096  IX2=IDRWX2  !  ENDING  X  COORDINATE 

0097  IY2=IDRWY2  !  ENDING  Y  COORDINATE 

0098  999  RETURN  !  RETURN  TO  CALLING  ROUTINE 

0099 

0100  ! - FORMAT  STATEMENT - 

0101  1  FORMATC  **  ERROR  IN  '  ’CLIPT",  AT  LEAST  ONE  END  MUST  BE  '  , 

0102  +  'CLIPPED  ** '  ) 

0103  END 


C-G,  ^ 


0001 

0002 

)003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 

0011 

0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 

0021 

0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

)030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 

0055 

\056 

Jb57 

0058 

0059 


SUBROUTINE  CNNCT ( SEG , PNDX , R ) 

PROLOGUE: 

MODULE  NAME:  CNNCT 

AUTHOR:  E.  PETRI DES  &  P.  FRAGEORGIA  OF  SYSCON,  INC 

RECODED:  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  1982  &  6/84  (FORTRAN  77) 

FUNCTION:  THIS  SUBROUTINE  IS  DESIGNED  TO  SELECT  SORT  AND  CONNECT  UP 
POLYGONS  FROM  THE  FOUR  QUADRANTS  OF  DATA  READ  FROM  THE  DATA 
BASE.  ADJACENT  POLYGONS  WITH  THE  SAME  CODE  ARE  THEN  CONNECTED 
TO  FORM  ONE  WHICH  WILL  BE  DISPLAYED.  THE  POLYGON  ARE  SORTED 
ACCORDING  TO  THEIR  DISTANCE  FROM  THE  SHIP. 

INPUTS: 

OUTPUTS : 

MODULES  CALLED:  ENDl ,  END 2 ,  KMOD 


!  CALLED  BY:  CRUNCH 

j 

INCLUDE  'MAP. PAR' 

1  PARAMETER  STOLEN=3800 

1  PARAMETER  SEGLEN=60 ,  POLLEN=40 

1  PARAMETER  WRKLEN=1000,  NDXLEN=300 

1  PARAMETER  MAXDTY=3 

1  PARAMETER  TOL=3 

1  PARAMETER  DEG=57 . 2957795 

1  PARAMETER  RAD= .017453293 

1  PARAMETER  PI  =  3 . 14159265 

1  PARAMETER  ERAD=3440.3 

1  PARAMETER  S251=63001 

1  PARAMETER  TW015=32768 

1 

1  !  INTEGER* 2  MAXDTY ,NDXLEN, POLLEN, SEGLEN, STOLEN, TOL,WRKLEN 

1  !  INTEGER*4  S251,TW015 

1  !  REAL  *  4  DEG , ERAD , P I , RAD 

INCLUDE  ' CS . INC ' 

1  !  - CS - 

1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

1  i -  -  -  - 

1  !  S  -1,3800  POLYGON  AND  SEGMENT  STORAGE  ARRAY  REAL *4 

1  !  STOLEN  STORAGE  ARRAY  LENGTH  (FOR  SEGS  &  POLYS)  PARM 

1  ! 

1  REAL *4  S ( -1 : STOLEN ) 

1 

1  COMMON  /CS/  S 

1  ! - CS-END - 

1 

i 

!  VARBL  SIZE  PURPOSE  TYPE  RANGE 


ENDl  USER  FUNCTION  INTEGER* 2 
END 2  USER  FUNCTION  INTEGER* 2 
F  FIRST  ENDPOINT  FOUND  FLAG  BYTE 

I  LOOP  COUNTER  INTEGER* 2 

II  LOOP  COUNTER  INTEGER* 2 
I SAVE  SAVE  INDEX  OF  NEW  POLYGON  INTEGER* 2 
J  LOOP  COUNTER  INTEGER* 2 
JJ  LOOP  COUNTER  INTEGER* 2 
K  LOOP  COUNTER  INTEGER* 2 
KK  LOOP  COUNTER  INTEGER* 2 
KMOD  USER  FUNCTION  INTEGER* 2 


c-7.  I 


0060 

0061 

1)062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 

0081 

0082 

0083 

0084 

0085 

0086 

0087 

0088 

)089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 

0101 

0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 

0111 

0112 

0113 

0114 

0115 

)ll6 

0117 

0118 


N 

POLYGON 

N 

INTEGER* 2 

NDX 

INDEX 

INTEGER* 2 

NN 

POLYGON 

NN 

INTEGER* 2 

PNDX  (0,160) 

POLYGON 

INDEX  ARRAY 

INTEGER*2 

PPl 

SEGMENT 

SECOND  ENDPOINT 

INTEGER*2 

PP2 

SEGMENT 

SECOND  ENDPOINT 

INTEGER*2 

PI 

SEGMENT 

FIRST  ENDPOINT 

INTEGER*2 

P2 

SEGMENT 

FIRST  ENDPOINT 

INTEGER*2 

R 

ERROR  RETURN  FLAG 

BYTE 

SEG 

1  OF  4  : 

INTERIOR  BORDER  SEGS 

INTEGER* 2 

***  VARIABLES 

NOT  LISTED  HERE  SHOULD  APPEAR 

IN  COMMONS  *** 

INTEGER* 2  1 ,  1 1 , ISAVE, J, JJ , K,KK,N,NDX,NN 
INTEGER *2  PNDX( 0 : 4*POLLEN) , PPl , PP2 , PI , P2 , SEG 
INTEGER *2  ENDl , END 2 , KMOD  ! FUNCTIONS 

BYTE  R,F 

R=. FALSE.  !  SET  ERROR  FLAG 

IF  (PNDX(O) .GT. 4*POLLEN)  GOTO  101  !  CHECK  TOTAL  NUM  OF  POLS 


DO  14  1=1 , PNDX( 0 ) -1 
N=PNDX( I ) 

DO  13  J=1 , S ( N+l ) 

IF  (ABS(S(N+J+2) ) .NE.SEG  .OR.  S(N+l).LT.l) 
GOTO  13 
F=. FALSE. 

DO  12  11=1+1, PNDX(0) 

NN=PNDX( II) 

DO  11  JJ=1 , S ( NN+1 ) 

IF  ( S ( NN+1 ) . LT . 1 . 

GOTO  11 

IF  ( . NOT . F )  THEN 
P1=END1 ( N, J ) 

P2=END2(N,J) 

F= . TRUE . 

END  IF 

PP1=END1(NN, JJ) 

PP2=END2 (NN, JJ) 

IF  (ABS(P1-PP2) .GT.TOL  .OR 


PROCESS  EACH  POL  EXCEPT  LAST 
PROCESS  ALL  BUT  LAST  POL 
SET  POLYGON  N 
DO  EACH  SEG  IN  POL  N 

!  NOT  INTERIOR 
BORDER  OR  <  1 
1ST  ENDPT  FOUND  FLAG 
ALL  POLS  AFTER  N 
!  SET  POLYGON  NN 
!  DO  EACH  SEG  IN  POL  NN 
.OR.  S(NN+JJ+2) .NE.  -S(N+J+2)) 

NO  SEGS  IN  POLYGON 
NOT  1ST  ENDPOINT 
ASSIGN  FIRST  ENDPOINT 
ASSIGN  FIRST  ENDPOINT 
1ST  ENDPT  FOUND  FLAG 
END  IF  BLOCK 
ASSIGN  SECOND  ENDPOINT 
ASSIGN  SECOND  ENDPOINT 
ABS ( P2-PP1 ) .GT.TOL 


.OR.  S(N) .NE.S(NN) )  GOTO  11  1  DO  NEXT  SEGMENT 


* 


- CONNECT  TWO  POLYGONS - 

NDX=S ( 0 )  !  SET  LENGTH  OF  ARRAY 

IF  ( S (N+l )+S (NN+1 )+S(N+2)+S(NN+2)+l.GT. 


S(-l)-NDX)  GOTO  103  ! 
ISAVE=NDX+1  ! 

S (NDX+1 ) =S ( N)  ! 

S ( NDX+2 ) =S ( N+l ) +S ( NN+1 ) -2  ! 

S ( NDX+3 ) =S ( N+2 ) +S ( NN+2 )  ! 

NDX=NDX+3  ! 

DO  4  K=1 , S (N+l)  ! 

IF  (K.NE.J)  THEN  ! 

NDX=NDX+1  ! 

S (NDX) =S(N+K+2 )  ! 

ELSE  ! 

DO  3  KK=JJ+1 , JJ+S(NN+1) -1 
NDX = NDX+1  ! 


CHECK  FOR  OVERFLOW 
SAVE  INDEX  OF  NEW  POL 
STORE  MGS/SSP  CODE 
STORE  COMBINED  SEG  COUNT 
STORE  COMB  LABEL  COUNT 
INCREMENT  INDEX 
STORE  SEGS  FROM  POL  N 
NOT  =  SEG  IN  OUTER  LOOP 
INCREMENT  INDEX 
STORE  SEG  FROM  POL  N 
K  =  J 

!  STORE  SEGS  FROM  POL  NN 
INCREMENT  INDEX 


C-  7.  z- 


0119  S (NDX ) =S ( 2+NN+ ( KMOD (KK-1, IIFIX(S( NN+1 ) ) )+l) ) 

Q120  3  CONTINUE  !  END  DO  LOOP 

)l21  END  IF  !  END  IF  BLOCK 

0122  4  CONTINUE  !  END  DO  LOOP 

0123  DO  5  K=1 , S ( ISAVE+1 )  !  CHECK  ADJACENT  BORDERS 

0124  KK=KMOD(K, I IFIX(S( ISAVE+1) ) )+l  !  POINTER 

0125  IF  ( S ( ISAVE+K+2 ) . EQ . -S ( ISAVE+KK+2 ) )  GOTO  6!EXIT  LOOP 

0126  5  CONTINUE  !  END  DO  LOOP 

0127  GOTO  8  !  SKIP  NEXT 

0128 

0129  ! - ELIMINATE  ADJACENT  INERIOR  BORDER  SEGS 

0130  6  S( ISAVE+K+2 )=0.  !  ZERO  OUT  STORAGE 

0131  S( ISAVE+KK+2 )=0.  !  ZERO  OUT  STORAGE 

0132  KK=0  !  RESET  POINTER 

0133  DO  7  K=ISAVE+3, ISAVE+S( ISAVE+1) +2  !  ELIMINATE  SEGMENT 

0134  IF  (S(K).NE.O.)  S(K-KK)=S(K)  !  RESET  STORAGE  ARRAY 

0135  IF  (S(K).EQ.O.)  KK=KK+1  !  RESET  POINTER 

0136  7  CONTINUE  !  CONTINUE 

0137  S ( ISAVE+1 )=S( ISAVE+1) -2  !  RESET  STORAGE  ARRAY 

0138  NDX=NDX-2  !  RESET  INDEX 

0139 

0140  ! - STORE  LABELS  FROM  N - 

0141  8  DO  9  K=N+3+S(N+l) , N+2+S ( N+l ) +S (N+2 )  !  FOR  LABELS 

0142  IF  (S(N+2) .GE.l. )  THEN  !  STORED  >=  1 

0143  NDX=NDX+1  !  INCREMENT  INDEX 

0144  S ( NDX) =S  ( K )  !  STORE  LABELS  FROM  N 

0145  END  IF  !  END  IF  BLOCK 

0146  9  CONTINUE  !  END  DO  LOOP 

^147 

A  4  8  ! - STORE  LABELS  FROM  NN - 

0149  DO  10  KK=NN+ 3+S (NN+1 ) , NN+2+S ( NN+1 ) +S ( NN+2 ) !  FOR  LABELS 

0150  IF  (S(NN+2) .GE.l. )  THEN  !  STORED  >=  1 

0151  NDX=NDX+ 1  !  INCREMENT  INDEX 

0152  S (NDX)=S (KK)  !  STORE  LABELS  FROM  NN 

0153  END  IF  !  END  IF  BLOCK 

0154  10  CONTINUE  !  END  DO  LOOP 

0155  PNDX ( I ) =0  !  DELETE  POL  REFERENCE  N 

0156  PNDX (II) = ISAVE  !  STORE  NEW  POL  ON  TOP  OF  NN 

0157  S ( 0 ) =NDX  !  UPDATE  USED  LENGTH  OF  S 

0158  GOTO  14  !  EXIT  LOOPS 

0159  11  CONTINUE  !  END  DO  LOOP 

0160  12  CONTINUE  !  END  DO  LOOP 

0161  13  CONTINUE  !  END  DO  LOOP 

0162  14  CONTINUE  !  END  DO  LOOP 

0163  GO  TO  999  !  TO  CALLING  ROUTINE 

0164 

0165  ! - ERROR  STATEMENTS - 

0166  101  WRITE( 5,102)  !  POL  INDEX  ARRAY  OVERFLOW 

0167  R= . TRUE .  !  SET  ERROR  FLAG 

0168  GO  TO  999  !  RETURN  TO  CALLING  ROUTINE 

0169  103  WRITE (5,104)  !  STORAGE  ARRAY  OVERFLOW 

0170  R= .TRUE .  !  SET  ERROR  FLAG 

0171  999  RETURN  !  TO  CALLING  ROUTINE 

0172 

017  3  ! - FORMAT  STATEMENTS - 

°174  102  FORMAT (X, 'POLYGON  INDEX  ARRAY  OVERFLOW  IN  CNNCT ' ) 

<L75  104  FORMAT  (X, 'STORAGE  ARRAY  OVERFLOW  IN  CNNCT') 

0176  END 


C-7,  3 


0001 

0002 

1003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 

0011 

0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 

0021 

0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

)030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 


SUBROUTINE  CONECT(MX,MY,NEWX,NEWY) 

!  PROLOGUE: 

!  MODULE  NAME:  CONECT 

!  AUTHOR:  J.  CASCIO,  W.  WACHTER ( FORTRAN  77),  NUSC/NL,  CODE  3333 
!  DATE:  1981  &  9/84  (FORTRAN  77) 

!  FUNCTION:  DRAWS  A  VECTOR  BETWEEN  THE  POINTS  (MX, MY)  AND  ( NEWX , NEWY ) 
!  SETS  CURRENT  POSITION  TO  (NEWX, NEWY) 

!  INPUTS:  COORDINATES  OF  TWO  POINTS  TO  BE  CONNECTED 
!  OUTPUTS:  VECTOR  DRAWN  BETWEEN  POINTS 
!  MODULES  CALLED:  NONE 
!  CALLED  BY:  CONCTU,  SVPGRF 

j 


INCLUDE  ' TK4025 . INC ' 

1  i - TK40  25 - 

1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

1  ! -  -  -  - 

1  !  KBEAMX  CURRENT  BEAM  X  POSITION  INTEGER*2 

1  !  KBEAMY  CURRENT  BEAM  Y  POSITION  INTEGER* 2 

1 

1  I NTEGER*2  KBEAMX , KBEAMY 

1 

1  COMMON/TK4 0 2 5/KBEAMX, KBEAMY 

1  ! - TK4025  END - 


VARBL 

SIZE  PURPOSE 

MX 

STARTING 

X  COORDINATE 

MY 

STARTING 

Y  COORDINATE 

NEWX 

ENDING  X 

COORDINATE 

NEWY 

ENDING  Y 

COORDINATE 

INTEGER* 2  MX , MY , NEWX , NEWY 

WRITE (5,1)  MX , MY , NEWX , NEWY 
KBEAMX=NEWX 
K  B  E AM Y = NEWY 
RETURN 


TYPE  RANGE 


INTEGER *2 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2 


PUT  COMMAND  OUT  TO  THE  TERMINAL 
UPDATE  X  CURRENT  POSITION 
UPDATE  Y  CURRENT  POSITION 
RETURN  TO  CALLING  ROUTINE 


--FORMAT  STATEMENTS - 

1  FORMAT ( '  ! VEC  ',415) 

END 


C-  f.f 


0001 
0002 
2  0  0  3 
0004 
0005 
0006 
0007 
0008 
0009 
0010 
0011 
0012 
0013 
0014 
0015 
0016 
0017 
0018 
0019 
0020 
0021 
0022 
0023 
0024 
0025 
0026 
0027 
0028 
<*029 
70  30 
0031 
0032 
0033 
0034 
0035 
0036 
0037 
0038 
0039 
0040 
0041 
0042 
0043 
0044 
0045 
0046 
0047 
0048 
0049 
0050 
0051 
0052 
0053 
0054 
0055 
N356 
2357 
0058 
0059 


SUBROUT I NE  CRUNCH ( RECNDX , I NFO , DTYPE f I Y , I X , R ) 

PROLOGUE: 

MODULE  NAME:  CRUNCH 

AUTHOR:  E.  PETRIDES  &  P.  FRAGEORGI A  OF  SYSCON,  INC 

RECODED:  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  1982  &  6/84  (FORTRAN  77) 

FUNCTION: 

THIS  SUBROUTINE  IS  DESIGNED  TO: 

1)  CHECK  TO  SEE  IF  DATA  FOR  EACH  QUADRANT  EXISTS 

2)  CALL  OTHER  SUBROUTINES  TO  GET  DATA,  CONNECT  SEGMENTS, 
AND  TAKE  CARE  OF  DOUGHNUT  MIDDLES  OF  CONNECTED  POLYGONS 

3)  COMPILE  POLYGON  OR  SEGMENT  LISTS 

4)  CALL  SUBROUTINE  TO  DO  ROTATIONAL  ANALYSIS  ON  POLY¬ 
GONS  OR  DISTANCE  ANALYSIS  ON  SEGMENTS 

5)  SORT  THE  POLYGONS  OR  SEGMENTS  ACCORDING  TO  DISTANCE 

6)  RETURN  CODES  AND  DISTANCES 

INPUTS:  HARD  COPY  SELECTION,  OPERATOR  SELECTION  TO  UPDATE 
PARAMETERS  OR  NOT.  VARIABLES  IN  COMMONS. 

OUTPUTS:  CRT  PROMPTING  MESSAGES  TO  OPERATOR 

MODULES  CALLED:  BMOD ,  CNNCT ,  DNUT ,  GETREC,  INDX,  OPNFIL,  PD I ST 
CALLED  BY:  MAP 


PARAMETER  MINNUM=1 . E-20 
PARAMETER  MAXNUM=1.E21 
PARAMETER  EPSLN=l.E-5 
INCLUDE  'MAP. PAR' 

1  PARAMETER  STOLEN=3800 

1  PARAMETER  SEGLEN=60 ,  POLLEN=40 

1  PARAMETER  WRKLEN=1000,  NDXLEN=300 

1  PARAMETER  MAXDTY  =  3 

1  PARAMETER  TOL=3 

1  PARAMETER  DEG=57 . 2957795 

1  PARAMETER  RAD= . 017453293 

1  PARAMETER  PI-3 . 14159265 

1  PARAMETER  ERAD=3440.3 

1  PARAMETER  S251=63001 

1  PARAMETER  TW015=32768 

INCLUDE  ' CFILE . INC ' 

1  I  - CFILE.  INC - 

1  <  VARBL  SIZE  PURPOSE 

1  ! -  - 

1  !  FNAME  (21)  MAP  FILE  NAME 

1  !  OPEN  OPEN  FLAG 

1  ! 

1  LOG I CAL *1  OPEN 

1  CHARACTER* 1  FNAME (21) 

1 

1  COMMON  /CFILE/  OPEN, FNAME 

1  ! - END  CFILE.  INC 

1 

INCLUDE  'CL. INC' 

1  j  - CL.  INC - 

1  !  VARBL  SIZE  PURPOSE 

1  ! -  - 

1  !  LATMAX  MAXIMUM  LATIITUDE 

1  !  L ATM I N  MINIMUM  LATIITUDE 


1 


LNGMAX 


MAXIMUM  LONGITUDE 


1 


LNGMIN 


MINIMUM  LONGITUDE 


TYPE  RANGE 


CHAR 

LOGICAL*!  .FALSE. 


TYPE  RANGE 

INTEGER*2 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2 


c-v 


0060 
0061 
VO  62 
0063 
0064 
0065 
0066 
0067 


0078 
0079 
0080 
0081 
0082 
0083 
0084 
0085 
0086 
0087 
<1088 
Jo  8  9 
0090 
0091 
0092 
0093 
0094 
0095 
0096 
0097 
0098 
0099 
0100 
0101 
0102 
0103 
0104 
0105 
0106 
0107 


1 

1 

1 

1 

1 

1 


INTEGER* 2  LATMIN , LATMAX , LNGMIN , LNGMAX 

COMMON  /CL/  LATMIN, LATMAX, LNGMIN, LNGMAX 
- END  CL. INC - 


INCLUDE  ' CLOC. INC  * 


1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 


-CLOC. INC  - 


0068 

1 

i 

VARBL  SIZE 

PURPOSE 

TYPE 

0069 

1 

i 

• 

— 

0070 

1 

j 

BLAT 

BASE  LATITUDE 

REAL *4 

0071 

1 

i 

BLNG 

BASE  LONGITUDE 

REAL *4 

0072 

1 

i 

• 

LAT 

LATITUDE  OF  SHIP'S 

LOCATION 

REAL *4 

0073 

1 

i 

LNG 

LONGITUDE  OF  SHIP'S 

LOCATION 

REAL *4 

0074 

1 

i 

• 

NMLT50 

#  OF  NAUTICAL  MILES 

PER  50TH 

DEGREE 

REAL *4 

0075 

1 

i 

OF  LATITUDE 

0076 

1 

i 

• 

NMLG50 

#  OF  NAUTICAL  MILES 

PER  50TH 

DEGREE 

REAL *4 

0077 

1 

j 

OF  LONGITUDE 

RANGE 


REAL *4  LAT , LNG , BLAT , BLNG , NMLT50 ,NMLG50 

COMMON  /CLOC/  LAT , LNG , BLAT , BLNG, NMLT50 , NMLG50 

- end  CLOC. INC - 

INCLUDE  'CLOG. INC' 

- CLOG. INC - 

VARBL  SIZE  PURPOSE 


TYPE  RANGE 


CNVRT (-1:0) 

DG 

DL 


BYTE  CNVRT (-1:0) , DG , DL 

COMMON  /CLOG/  CNVRT , DL , DG 

- END  CLOG. INC - 

INCLUDE  ' CS . INC ' 

- cs - 


VARBL  SIZE 


PURPOSE 


S  -1,3800  POLYGON  AND  SEGMENT  STORAGE  ARRAY 
STOLEN  STORAGE  ARRAY  LENGTH  (FOR  SEGS  &  POLYS) 

REAL  *  4  S ( - 1 : STOLEN ) 

COMMON  /CS/  S 


TYPE  RANGE 

REAL *4 
PARM 


-CS-END- 


0108 

l  VARBL  SIZE 

PURPOSE 

TYPE 

0109 

i  -  _  _ 

— 

0110 

!  AFILE 

FILE  TO  BE  OPENED 

BYTE 

0111 

!  AX 

X  COORDINATE  OF 

POINT 

A 

REAL*4 

0112 

!  AY 

Y  COORDINATE  OF 

POINT 

A 

REAL *4 

0113 

!  B 

POINT  B 

REAL* 4 

0114 

!  BX 

X  COORDINATE  OF 

POINT 

B 

REAL *4 

^15 

!  BY 

Y  COORDINATE  OF 

POINT 

B 

REAL *4 

A16 

<  DA 

BOTTOM  DEPTH  AT 

CLOSEST  POINT 

REAL*4 

0117 

!  D I STAB 

DISTANCE  FROM  A 

TO  B 

REAL *4 

0118 

1  DISTAT 

DISTANCE  FROM  A 

TO  T 

REAL *4 

RANGE 


0119 

!  DISTBT 

DISTANCE  FROM  B  TO  T 

REAL *4 

0120 

!  DL 

ROTATION  FOR  POLYGON  FLAG 

BYTE 

b  121 

!  DTYPE 

DATA  TYPE  BEING  USED 

I NTEGER*2 

0122 

!  I 

LOOP  INDEX 

INTEGER*2 

0123 

!  IB 

(4) 

CONSTANTS  2,5,8,11 

REAL *4  2,5,8, 

0124 

!  INFO 

INFO  PASSED  TO  THE  MAIN  PROGRAM 

REAL *4 

0125 

!  INDX 

FUNCTION 

INTEGER* 2 

0126 

!  IX 

(4) 

POSITION  OF  THE  CURRENT  QUADRANT 

INTEGER* 2 

0127 

!  IY 

(4) 

POSITION  OF  THE  CURRENT  QUADRANT 

INTEGER* 2 

0128 

!  J 

LOOP  INDEX 

INTEGER* 2 

0129 

!  K 

TEMPORARY  STORAGE 

REAL *4 

0130 

!  NDX 

DATA  BASE  INDEX 

I NTEGER*4 

0131 

!  PDIST 

FUNCTION 

INTEGER* 2 

0132 

!  PNDX 

(0:160) 

POLYGON  INDEX 

I NTEGER*2 

0133 

!  R 

ERROR  FLAG 

BYTE 

0134 

!  RECNDX 

() 

POINTERS  INTO  THE  DATA  BASE 

INTEGER* 2 

0135 

!  SLOPAB 

SLOPE  OF  SEGMENT  AB 

REAL *4 

0136 

!  SLOPTS 

SLOPE 

REAL *4 

0137 

!  SNDX 

(0:240 

SEGEMNT  INDEX 

INTEGER* 2 

0138 

>  T 

POINT  T 

REAL *4 

0139 

!  TX 

X  COORDINATE  OF  POINT  T 

REAL *4 

0140 

!  TY 

Y  COORDINATE  OF  POINT  T 

REAL  *4 

0141 

!  T1 

LENGTH  OF  POLYGON/SEGMENT  LIST 

INTEGER*2 

0142 

0143 

!  T2 

i 

LENGTH  OF  POLYGON/SEGMENT  LIST 

INTEGER* 2 

0144 

0145 

!  ***  VARIABLES 

NOT  LISTED  HERE  SHOULD  APPEAR  IN 

COMMONS  *** 

0146 

0147 

REAL*4 

REAL*4 

AX , AY , BX , BY , TX , TY , DA , DB , D I STAB , D I STAT , D I STBT , B 
SLOPAB , S  LOPTS , I NFO , K , T , BMOD , BD I V 

i  148 

INTEGER*4  NDX 

0149 
0150 
0151 
0152 
0153 
0154 
0155 
0156 
0157 
0158 
0159 
0160 
0161 
0162 
0163 
0164 
0165 
0166 
0167 
0168 
0169 
0170 
0171 
0172 
0173 
917  4 
717  5 
0176 
0177 


INTEGER*2 
INTEGER*2 
INTEGER*2 
INTEGER* 2 
BYTE 
DATA 


I , IB ( 4 ) , INDX , IX ( 4 ) , I Y( 4 ) , SNDX (0:4  *SEGLEN ) 

PDIST , PNDX (0:4  *POLLEN ) ,T1,T2,J 

RECNDX ( ( LATMAX-LATMIN) * ( LNGMAX-LNGMIN ) *MAXDTY ) 
DTYPE 


AFI LE ,  R 
IB 


72,5,8,11/ 


BD I V ( B , I ) =AINT ( B/FLOAT ( I ) ) 
AFI LE=. FALSE. 

R=. FALSE. 

S ( 0 ) =12 . 

DO  1  I =0 , 4*SEGLEN 
SNDX ( I ) =0 
CONTINUE 

DO  2  1=0,4  *POLLEN 
PNDX ( I ) =0 
CONTINUE 

IF  (.NOT. OPEN)  CALL 
IF  (R)  GO  TO  999 


INITIALIZATION - 

TRUNCATING  DIVISION 
SET  TO  DATA  ("B")  FILE 
SET  ERROR  FLAG 

NUMBER  INITIAL  EDGE  SEGMENTS 
FOR  ALL  SEGMENTS 
INITIALIZE  SEGMENT  INDEX 
END  LOOP 

FOR  ALL  POLYGONS 
INITIALIZE  POLYGON  INDEX 
END  LOOP 
OPNF I L ( AF I LE , R )  !  OPEN  FILE 

!  IF  ERROR  IN  OPEN,  RETURN 


- VALIDATE  &  PROCESS  EACH  QUADRANT 

DO  3  1=1,4  !  FOR  5  DEG  SQUARES  DISPLAYED 

NDX=RECNDX ( INDX ( I Y ( I ) , IX ( I ) , DTYPE ) )  !  GET  INDEX  POINTER 

IF  (NDX.EQ.-TW015)  GOTO  3  !  NO  DATA  FOR  THE  SQUARE 

NDX=NDX+TW01 5  !  OFFSET  DATA  BASE  INDEX 

CALL  GETREC (SNDX, PNDX, I , DTYPE, NDX,R)  !  GET  DATA  FOR  SQUARE 
IF  (R)  GO  TO  999  !  IF  ERROR  IN  GETREC,  RETURN 

CONTINUE  !  END  LOOP 


0178  IF  (DG)  GOTO  6  !  NOT  POLYGON  DATA 

0179  ! 

J180  ! - CONNECT  ADJACENT  POLYGONS - 

0181  DO  4  1=1,4  !  LOOP  TO  CONNECT  POLY  SEGS 

0182  CALL  CNNCT ( I B ( I ) , PNDX , R )  !  CONNECT  POLYGONS  TOGETHER 

0183  IF  (R)  GO  TO  999  !  IF  ERROR  IN  CONNECT,  RETURN 

0184  4  CONTINUE  !  END  LOOP 

0185  ! 

0186  ! - ELIMINATE  NEWLY  CREATED  MIDDLES 

0187  DO  5  1=1,4  !  LOOP  TO  DELETE  MIDDLES 

0188  CALL  DNUT ( I B ( I ) , PNDX , R )  !  ELIMINATE  DOUGHNUT  MIDDLES 

0189  IF  (R)  GO  TO  999  !  IF  ERROR  IN  DNUT,  RETURN 

0190  5  CONTINUE  !  END  LOOP 

0191  ! 

0192  ! - SAVE  SEGMENT  OR  POLYGON  LIST 

0193  6  T1=IIFIX(S(0) )+l  !  SAVE  STORAGE  ARRAY  INDEX 

0194  IF  (DG)  GOTO  8  !  IF  NOT  POLYGON  DATA  BRANCH 

0195  DO  7  1  =  0,4 *POLLEN  !  COPY  POL  LIST  INTO  SEG  LIST 

0196  SNDX ( I ) =PNDX ( I )  !  FILL  SEGMENT  INDEX  ARRAY 

0197  7  CONTINUE  !  END  LOOP 

0198  8  T2=SNDX ( 0 )  !  SAVE  LENGTH  OF  SEG/POL  LIST 

0199  J=0  !  RESET  ZAPPED  POLYGON  COUNT 

0200  DO  9  I=1,T2  !  THROW  OUT  ZAPPED  POLYGONS 

0201  IF  ( SNDX ( I ) . NE . 0 )  SNDX ( I - J ) =SNDX ( I )  !  REMOVE  FROM  LIST 

0202  IF  ( SNDX ( I ) . EQ . 0 )  J=J+1  !  CORRECT  INDEX 

0203  9  CONTINUE  !  END  LOOP 

0204  T2=T2-J  !  SAVE  LENGTH  OF  NEW  POLL I ST 

0205  SNDX ( 0 ) =T2  !  STORE  #  OF  SEGMENTS  OR  POLS 

1206  ! 

/207  ! - STORE  POLYGON  LIST  AND  LENGTH- 

0208  IF  ( 2 . *T2 . GT . ( S ( -1 ) ) -T1 )  GOTO  101  !  ERROR : STORAGE  ARRAY  OVERFLOW 

0209  S(Tl)=FLOATI (T2)  !  STORE  LENGTH  OF  SEG/POL  LIST 

0210  DO  10  1=1, T2  !  STORE  SEG/POL  LIST , DISTANCES 

0211  S(T1+I)=(SNDX(I))  !  STORE  SEGMENT  OR  POLYGON 

0212  IF  (DL)  S (T1+T2+I ) =PDIST ( SNDX ( I ) )  !  ROTATION  FOR  POLS 

0213  IF  (DG)  S (T1+T2+I ) =SQRT( S ( SNDX ( I ) +2 ) ) !  DISTANCE  FOR  SEGS 

0214  10  CONTINUE  !  END  LOOP 

0215  ! 

0216  ! - SORT  POLYGONS  OR  SEGMENTS  ACCORDING  TO  DISTANCE  FROM  SHIP 

0217  IF  (T2.LE.1)  GOTO  15  !  ONLY  ONE  SEGEMNT  OR  POLYGON 

0218  11  DO  13  I=T1+T2+1,T1+2*T2-1  !  FOR  DISTANCES  OF  POL  OR  SEG 

0219  DO  12  J=I+1 ,T1+T2*2  !  FOR  DISTANCES  OF  POL  OR  SEG 

0220  IF  (S(J) .LT.S(I) )  THEN  !  DISJOINT  POLYGONS 

0221  K=S ( J-T2 )  !  SWITCH  REFERENCE  CODES 

0222  S ( J-T2 ) =S ( I-T2 )  !  SWITCH  REFERENCE  CODES 

0223  S ( I-T2 ) =K  !  SWITCH  REFERENCE  CODES 

0224  K=S ( I )  !  SWITCH  DISTANCES 

0225  S(I)=S(J)  !  SWITCH  DISTANCES 

0226  S(J)=K  l  SWITCH  DISTANCES 

0227  END  IF  !  END  IF  BLOCK 

0228  12  CONTINUE  !  END  DO  LOOP 

0229  13  CONTINUE  !  END  DO  LOOP 

0230 

0231  ! - ELIMINATE  MULTIPLE  INTERIORITIES  OF  POLYGON  DISTANCES 

0232  IF  (S(T1+T2+1) .GE.0.  .OR.  S ( T1+T2+2 ) . GE . 0 . )  GOTO  15  !  DISTS>0 

^233  DO  14  I=T1+T2+2,T1+2*T2  !  MULTIPLE  INTERIORS  CHECK 

234  IF  (S(I).GE.O.)  GOTO  11  !  SHIP  NOT  INTERIOR  TO  POL 

0235  S(I-1)=-S(I)  !  SET  ALL  BUT  CLOSEST  POL  DIST 

0236  14  CONTINUE  !  END  DO  LOOP 


C-%H 


0237  GOTO  11  !  RESORT  POLYGON  DISTANCES 

0238 

JI239  ! - SEGMENT  DATA - 

0240  15  S( 0 ) =FLOATI (T1 )  !  RESET  #  OF  POLS  OR  SEGS 

0241  IF  ( . NOT . DG )  THEN  !  IF  POLYGON  DATA 

0242  INFO-S ( ( S ( Tl+1 ) ) )  1  SET  TO  MGS  OR  SSV  OF  POLYGON 

0243  GO  TO  999  !  RETURN  TO  CALLING  ROUTINE 

0244  END  IF  !  END  ID  BLOCK 

0245  16  IF  ((T2.LT.2)  .OR.  ( ABS ( S( S (Tl+1 ) +1) ) .GT . 355 )  !  ONLY  1  CONTOUR 

0246  *  .OR.  (S(T1+T2+1) .LE.2) )  INFO=S ( S(T1+1 ) +3 )  !  =BOTTOM  DEPTH 

0247  IF  (INFO.GE.O)  GO  TO  999  !  RETURN  TO  CALLING  ROUTINE 

0248  AX=BMOD( S (S (Tl+1 ) +4 ) ,501)  !  X  DIST  OF  CLOSEST  POINT 

0249  AY=BDI V( S( S (Tl+1 ) +4 ) ,501)  !  Y  DIST  OF  CLOSEST  POINT 

0250  DA=S (S(Tl+l)+3)  !  BOTTOM  DEPTH  AT  CLOSEST  PT 

0251  DO  17  1=2, T2  !  FOR  ALL  DISTANCES 

0252  IF  (S(S(T1+I )+3) .NE.DA)  THEN  !  NOT  =  BOTTOM  DEPTH 

0253  BX=BMOD( S ( S ( T 1 + I )+4) ,501)  !  X  DISTANCES 

0254  BY=BDIV(S(S(Tl+I)+4) ,501)  !  Y  DISTANCES 

0255  DB=S (S ( T1+ I ) +3 )  !  BOTTOM  DEPTH 

0256  GOTO  18  !  EXIT  LOOP 

0257  END  IF  !  END  IF  BLOCK 

0258  17  CONTINUE  !  END  DO  LOOP 

0259  BX=BMOD( S( S (Tl+2 ) +4 ) ,501)  !  X  DISTANCE 

0260  BY=BDIV (S(S(Tl+2)+4) ,501)  !  Y  DISTANCE 

0261  D8=S (S(Tl+2)+3)  !  BOTTOM  DEPTH 

0262 

0263  18  DISTAB=SQRT( (BX-AX) **2  +  ( BY- AY) **2 )  !  DISTANCE  FROM  A  TO  B 

0264  IF  ((AX.NE.BX)  .AND.  (AY.NE.BY))  SLOP AB= ( BY- AY) /( BX-AX)  ! SLOPE 

0265  IF  (AY.EQ.BY)  SLOPAB=MINNUM  !  SLOPE  OF  SEGMENT  AB 

) 2 6 6  IF  (AX.EQ.BX)  SLOPAB=MAXNUM  !  SLOPE  OF  SEGMENT  AB 

0267  SLOPTS=SLOPAB* ( -AX ) +AY  !  SLOPE 

0268  B=LNG/SLOPAB+LAT  !  LOCATION  OF  B 

0269  TX= ( B-SLOPTS ) / ( SLOPAB+l/SLOPAB )  !  X  DISTANCE 

0270  TY= ( B*SLOPAB**2+SLOPTS ) / ( l+SLOPAB**2 )  !  Y  DISTANCE 

0271  DISTAT=SQRT ( ( TX-AX) * *2  +  ( TY- AY } **2 )  !  DISTANCE  FROM  A  TO  T 

0272  DISTBT=SQRT ( (TX-BX ) **2+( TY-BY ) **2 )  !  DISTANCE  FROM  B  TO  T 

0273  IF  ( DISTAT+DISTBT . GT . DISTAB+EPSLN )  THEN  !  COMPARE  DISTANCES 

0274  IF  (DISTAT, LE.DISTBT)  THEN  !  A  TO  T  <=  B  TO  T 

0275  DISTAT=-AMIN1 (DISTAB/2. , DISTAT) !  DISTANCE  A  TO  T 

0276  ELSE  !  A  TO  T  >  B  TO  T 

0277  DISTAT=AMIN1 (DISTAT, DISTAB*1 . 5 )  !  DISTANCE  FROM  A  TO  T 

•  0278  END  IF  !  END  IF  BLOCK 

0279  END  IF  !  END  IF  BLOCK 

0280  20  IF  (DISTAB. EQ.O)  DISTAB=MINNUM  !  MINIMUM  DISTANCE  A  TO  B 

0281  INFO=10* ( ANINT ( ( ( DB-DA) * ( DISTAT/DISTAB ) +DA) /10 ) )  !  INFO 

0282  GO  TO  999  !  RETURN  TO  CALLING  ROUTINE 

0283 

0284  ! - ERRORS - 

0285  101  WRITE (5,102)  !  ARRAY  OVERFLOW  ERROR 

0286  R= . TRUE .  !  SET  ERROR  FLAG  TO  TRUE 

0287  999  RETURN  !  RETURN  TO  CALLING  ROUTINE 

0288 

0289  ! - FORMAT  STATEMENT - 

0290  102  FORMAT  (X,1 STORAGE  ARRAY  OVERFLOW  IN  CRUNCH') 

0291  END 
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SUBROUTINE  DNUT ( SEG , PNDX , R ) 

PROLOGUE: 

MODULE  NAME:  DNUT 

AUTHOR:  E.  PETR IDES  &  P.  FRAGEORGI A  OF  SYSCON,  INC 
RECODED:  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  1982  &  6/84  (FORTRAN  77) 

FUNCTION:  SUBROUTINE  DOUGHNUT  IS  DESIGNED  TO: 

1)  DETECT  POLYGON  DOUGHNUT  STRUCTURES 

2)  REMOVE  INTERIOR  BORDER  SECTIONS  OF  THE  POLYGONS 
THAT  ALLOW  THEIR  FORMATION 

3)  ELIMINATE  DOUGHNUT  MIDDLE  SEGMENT  FROM  THE  POLYGON 
INPUTS:  POLYGONS  WITH  DOUGHNUT  STRUCTURES 

OUTPUTS:  POLYGONS  WITHOUT  DOUGHNUT  STRUCTURES 
MODULES  CALLED:  ENDl,  END 2 ,  FNP ,  KMOD 
CALLED  BY:  CRUNCH 


NOTE:  ALL  LOOPS  IN  THIS  SUBROUTINE  ARE  PRETEST  LOOPS  THAT  ARE 
MANUALLY  CREATED.  THIS  ALLOWS  LOOP  EXECUTION  TO  BE 
EASILY  BY-PASSED. 

J-JJ:  DENOTES  SUB-POLYGON  DEFINED  BY  SEGMENTS  J  THRU  JJ 
JJ-J:  DENOTES  SUB-POLYGON  DEFINED  BY  SEGMENTS  JJ  THRU  J 
(THE  LATTER  WRAPS  AROUND  THE  SEGMENT  LIST) 

CROSS  POINT:  A  SEGMENT  ENDPOINT  ON  THE  LINE  DEFINED  BY  SEG 


INCLUDE  'MAP. PAR' 

1  PARAMETER  STOLEN=3800 

1  PARAMETER  SEGLEN=60 ,  POLLEN=40 

1  PARAMETER  WRKLEN=1000,  NDXLEN=300 

1  PARAMETER  MAXDTY  =  3 

1  PARAMETER  TOL=3 

1  PARAMETER  DEG=57 . 2957795 

1  PARAMETER  RAD= .017453293 

1  PARAMETER  PI=3 . 14159265 

1  PARAMETER  ERAD= 3440 . 3 

1  PARAMETER  S251=63001 

1  PARAMETER  TW015=32768 

1 

1  !  INTEGER* 2  MAXDTY , NDXLEN , POLLEN, SEGLEN, STOLEN, TOL,WRKLEN 

1  !  INTEGER* 4  S251,TW015 

1  !  REAL* 4  DEG , ERAD , P I , RAD 

INCLUDE  ' CBC1 . INC ' 

1  j  - CBC1.INC - 


1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

1  !  BCOORD  (-12:12,2)  ? 


1  ! 

1  INTEGER* 2  BCOORD( -12 : 12 , 2  ) 

1 

1  COMMON  /CBC/  BCOORD 

1  t - END  CBC1.INC 

1 

INCLUDE  ' CS . INC ' 

1  j  - cs - 


1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 


C-  (O.l 


0060 
0061 
P  0  6  2 
0063 
0064 
0065 
0066 
0067 
0068 
0069 
0070 
0071 
0072 
0073 
0074 
0075 
0076 
0077 
0078 
0079 
0080 
0081 
0082 
0083 
0084 
0085 
0086 
0087 
0088 

p89 
u0  90 
0091 
0092 
0093 
0094 
0095 
0096 
0097 
0098 
0099 
0100 
0101 
.0102 
0103 
0104 
0105 
0106 
0107 
0108 
0109 
0110 
0111 
0112 
0113 
0114 
0115 

)16 

U117 

0118 


1  !  S  -1,3800 
1  l  STOLEN 
1  ! 

1 
1 


POLYGON  AND  SEGMENT  STORAGE  ARRAY  REAL *4 

STORAGE  ARRAY  LENGTH  (FOR  SEGS  &  POLYS)  PARM 


1 

1 

1 


REAL *4  S(-l: STOLEN) 

COMMON  /CS/  S 


-CS-END- 


VARBL  SIZE 

PURPOSE 

TYPE  RANGE 

DDNEG 

DISTANCE  TO  FURTHEST  JJ-J  CROSS 

I NTEGER* 2 

DDPOS 

OVER  POINT  IN  NEG , POS  DIRECTION 

I NTEGER* 2 

DNEG 

DISTANCE  TO  FURTHEST  J-JJ  CROSS 

I NTEGER* 2 

DPOS 

OVER  POINT  IN  NEG, POS  DIRECTION 

I NTEGER* 2 

DUM 

GOSUB  SIMULATION  LABEL 

I NTEGER* 2 

END1 

FUNCTION 

I NTEGER* 2 

END  2 

FUNCTION 

INTEGER*2 

F 

1ST  ENDPOINT  FOUND  FLAG 

BYTE 

FNP 

FUNCTION 

I NTEGER* 2 

I 

COUNTER 

I NTEGER* 2 

J 

J-JJ  INDEX 

INTEGER* 2 

JJ 

JJ-J  INDEX 

I NTEGER *2 

K 

COUNTER 

I NTEGER* 2 

KK 

COUNTER 

I NTEGER* 2 

KMOD 

FUNCTION 

I NTEGER* 2 

N 

CURRENT  POLYGON 

I NTEGER* 2 

NEGT 

OFFEST  OF  SEGMENT  T 

I NTEGER* 2 

NUM 

NUMBER  OF  POLYGON  SEGMENTS 

I NTEGER* 2 

PNDX  (0,160) 

POLYGON  INDEX  ARRAY 

I NTEGER* 2 

PPl 

SEGMENT  JJ  ENDPOINT 

I NTEGER* 2 

PP2 

SEGMENT  JJ  ENDPOINT 

I NTEGER* 2 

PI 

SEGMENT  J  ENDPOINT 

I NTEGER* 2 

P2 

SEGMENT  J  ENDPOINT 

I NTEGER* 2 

R 

ERROR  RETURN  FLAG 

BYTE 

SEG 

1  OF  4  INTERIOR  BORDER  SEGMENTS 

I NTEGER* 2  2,5,1 

T 

SEGMENT 

I NTEGER* 2 

TT 

SECOND  ENDPOINT  OF  SEGMENT  T 

I NTEGER* 2 

X 

LONGITUDE 

I NTEGER* 2 

Y 

LATITUDE 

I NTEGER* 2 

***  VARIABLES  NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMONS  *** 
INTEGER *4  TT 

I NTEGER* 2  DDNEG , DDPOS , DNEG , DPOS , DUM , I , J , J J , K , KK , N , NEGT , NUM 
INTEGER* 2  PNDX( 0 : 4*POLLEN) , Pi , P2 , PPl , PP2 , SEG, T ,X, Y 
I NTEGER* 2  END1 , END 2 , FNP , KMOD  !  FUNCTIONS 
BYTE  R,  F 


| _ 

R=. FALSE. 

1=1 

!  SET  ERROR  FLAG  TO  FALSE 
!  INITIALIZE  LOOP  I  INDEX 

r  nDP  T 

i 

IF  ( I .GT.PNDX(O) ) 

GOTO 

16 

i  - 

!  TEST  FOR  END  OF  LOOP  I 

I F  ( PNDX ( I ) . LE . 0 ) 

GOTO 

15 

!  IF  INPROPER  POL,  INCREMENT 

2 

» - 

N=PNDX( I) 

NUM=S ( N+l ) 

J  =  1 

!  SET  CURRENT  POLYGON 
!  SET  NUMBER  OF  POL  SEGMENTS 
!  INITIALIZE  LOOP  J  INDEX 

- LOOP  J - 

C  -to.  ^ 


0119 

0120 

>121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

)l48 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 

0161 

0162 

0163 

0164 

0165 

0166 

0167 

0168 

0169 

0170 

0171 

0172 

0173 

°174 

>75 

0176 

0177 


3  IF  ( J . GT . S ( N+ 1 ) - 1 )  GOTO  15  !  TEST  FOR  END  OF  LOOP  J 

IF  ( ABS ( S (N+J+2 ) ) . NE . SEG)  GOTO  14  !  IF  NOT  INTERIOR  SEG 
F=. FALSE.  !  INIT  1ST  ENDPT  FOUND  FLAG 

JJ=J+1  !  INITIALIZE  LOOP  JJ  INDEX 


;  - 
4 


IF  (JJ.GT.NUM)  GOTO  14 
IF  ( S ( N+JJ+2 ) . NE . -S ( N+J+2 ) 
IF  ( . NOT . F )  THEN 
P1=END1 (N, J ) 

P2=END2 (N, J) 

F= .TRUE. 

END  IF 

PP1=END1 (N, JJ) 

PP2=END2(N, JJ) 


-LOOP  JJ - 

!  TEST  FOR  END  OF  LOOP  JJ 
GOTO  13  !  SEGS  OPPO  DIRECTIONS 


NOT  1ST  ENDPOINT  FOUND 
GET  SEG  J  ENDPOINTS 
GET  SEG  J  ENDPOINTS 
1ST  ENDPOINT  FOUND  FLAG 
END  IF  BLOCK 
GET  REST  OF  SEGS  ENDPTS 
GET  REST  OF  SEGS  ENDPTS 


(JJ) 

(JJ) 


ENDPS  ARE  NOT  CLOSE  ENOUGH 


I F ( ABS ( P1-PP2 ) .GT.TOL  .OR.  ABS ( P2-PP1 ) . GT . TOL )  GOTO  13 


-ELIMINATE  DOUGHNUT  MIDDLE  SEGMENTS 


6 


101 


DPOS=-l 

DNEG=-1 

K=J 

K=K+1 

IF  (K.LE.JJ-2 
ASSIGN  101 
GOTO  200 
IF  ( . NOT . F ) 
IF  (SEG.LE. 
IF  ( SEG.GT. 
IF  (T.GE.0) 
IF  (T.LT.0) 
GOTO  6 
END  IF 


FIND  MAX  J-JJ  CROSSOVER  DISTANCE 
J-JJ  CROSS  OVER  DISTANCE;  >0 
J-JJ  CROSS  OVER  DISTANCE;  <0 
INITIALIZE  INDEX  K 
INCREMENT  COUNTER  K 
)  THEN  !  IF  ALL  J  THRU  JJ  SEGS  DONE 

TO  DUM  !  FIND  OFFSET  LAT  OF  LNG  OF 

SEG  K  VIA  GOSUB  SIMULATION 
GOTO  6  !  IF  ENDPT  NOT  WITHIN  LIMITS 

6)  T=Y-P2  !  VERTICAL  INTERIOR  BORDER  SEG 

6)  T=X-P2  !  HORIZ  INTERIOR  BORDER  SEG 

DPOS=MAX ( DPOS , T )  !  MAX  ABSOLUTE  VALUE  OF 
DNEG=MAX ( DNEG , -T ) !  CROSSOVER  PT  DISTANCES 
!  DO  NEXT  SEGMENT 
!  END  IF  BLOCK 


8 


102 


- FIND 

DDPOS=-l  ! 

DDNEG=-1  ! 

KK=JJ  ! 

KK=KK+1  ! 

IF  (KK.LE.J+NUM-2)  THEN  ! 

K=KMOD(KK-l , NUM ) +1 
ASSIGN  102  TO  DUM  ! 

GOTO  200  ! 

IF  ( . NOT . F )  GOTO  8  ! 

IF  (SEG.LE. 6)  T=Y-PP2  ! 

IF  (SEG.GT. 6)  T=X-PP2  ! 

IF  (T.GE.0)  DDPOS =MAX ( DDPOS 
IF  (T.LT.0)  DDNEG=MAX ( DDNEG 
GOTO  8  ! 

END  IF  ! 


MAX  JJ-J  CROSSOVER  DISTANCE 
INIT  JJ-J  CROSSOVER  POS  DIST 
INIT  JJ-J  CROSSOVER  NEG  DIST 
INITIALIZE  INDEX  KK 
INCREMENT  INDEX  KK 
IF  ALL  JJ  THRU  J  SEGS  DONE 

FIND  OFFSET  LAT  OF  LNG  OF 
SEG  K  VIA  GOSUB  SIMULATION 
IF  ENDPT  NOT  WITHIN  LIMITS 
VERTICAL  INTERIOR  BORDER  SEG 
HORIZ  INTERIOR  BORDER  SEG 
T)  !  MAX  ABSOLUTE  VALUE  OF 
-T)!  CROSSOVER  PT  DISTANCES 
DO  NEXT  SEGMENT 
END  IF  BLOCK 


- THE  STRUCTURE  IS  INVALID - 

IF(DPOS.LT.O. AND. DNEG. LT.0)  GOTO  1001!  NO  CROSSPT  FOR  J-JJ 
IF ( DDPOS. LT.0. AND. DDNEG. LT.0)  GOTO  1001!  NO  JJ-J  CROSSPT 
IF ( (DPOS. LT.0. OR. DDPOS. LT.0) .AND. ! J-JJ  &  JJ-J  CROSSPTS  NOT 
(DNEG. LT.0 .OR. DDNEG. LT.0) )  GOTO  1001!  ON  THE  SAME  SIDE 
IF ( (DPOS. EQ. DDPOS  .AND.  DPOS.GE.0)  .OR.  !  IDENTICAL  CROSS - 


C-(Qh3 


0178  *  (DNEG.EQ.DDNEG  .AND.  DNEG.GE.O))  GOTO  1001  !  POINTS 

0179  I F ( DPOS . LT . DDPOS . AND . DNEG . GT . DDNEG )  GOTO  1001!  CROSS  OTHER 

0180 

0181  ! - WHICH  POLYGON  IS  INTERIOR  TO  OTHER 

0182  F=( DPOS. GT. DDPOS)  !  ASSUME  CROSSPTS  ON  POS  SIDE 

0183  !  IF  J-JJ  OR  JJ-J  DO  NOT  CROSS  POS  SIDE, 

0184  IF  (DPOS.LT.O  .OR.  DDPOS. LT.0)  F=( DNEG. GT. DDNEG)  !  SET  NEG 

0185  DO  10  K=1 , NUM  !  CLEAN  OUT  POLYGON  INTERIOR 

0186  IF  (.NOT.  F.AND.K.GE. J.AND.K.LE.JJ)  S(N+K+2)=0  !  SET=0 

0187  IF  (F  . AND . ( K . LE . J  .OR.  K.GE.JJ))  S(N+K+2)=0  !  SET=0 

0188  10  CONTINUE  !  END  LOOP 

0189 

0190  ! - CHECK  FOR  &  DELETE  ADJACENT  BORDERS 

0191  IF  (F)  J=J+1  !  INCREASE  J-JJ  INDEX 

0192  IF  ( . NOT . F )  J=J-1  !  DECREASE  J-JJ  INDEX 

0193  IF  (J.LT.l)  J=NUM  !  SET  TO  NUM 

0194  IF  ( . NOT . F )  JJ=JJ+1  !  INCREASE  JJ-J  INDEX 

0195  IF  (F)  JJ=JJ-1  !  DECREASE  JJ-J  INDEX 

0196  IF  (JJ.GT.NUM)  JJ=1  !  SET  TO  1 

0197  IF  ( S (N+J+2 ) . EQ. -S ( N+JJ+2 ) )  S(N+J+2)=0  !  DELETE  ADJACENT 

0198  IF _(S(N+J+2) .EQ.0)  S(N+JJ+2)=0  !  BORDER  SEGMENTS 

0199  KK=0  !  RESET  DELETED  SEGMENT  COUNT 

0200 

0201  ! - COMPRESS  ARRAY - 

0202  DO  11  K=N+3 , N+NUM+2  !  COMPRESS  SEG  REFERENCE  LIST 

0203  IF  (S(K).NE.O)  S(K-KK)=S(K)  !  MOVE  UP  SEGMENT  REFERENCES 

0204  IF  (S(K).EQ.O)  KK=KK+1  !  RESET  INDEX 

0205  11  CONTINUE  !  END  DO  LOOP 

0206  DO  12  K=N+NUM+3 , N+NUM+S ( N+2 ) +2  !  COMPENSATE  FOR  COMPRESS 

■\207  IF  ( S  (N+2 )  .  LE .  0 )  GOTO  12  !  NOT  LABEL  POINTS  IN  POLYGON 

<3208  S(K-KK)=S(K)  !  MOVE  UP  LABEL  POINTS 

0209  12  CONTINUE  !  END  DO  LOOP 

0210  S ( N+l ) =NUM-KK  !  UPDATE  SEGMENT  COUNT 

0211  GOTO  2  !  DO  FOR  NEXT  POLYGON 

0212  13  JJ=JJ+1  !  INCREMENT  JJ  INDEX 

0213  GOTO  4  !  DO  FOR  NEXT  J 

0214 

0215  ! - END  OF  LOOP  JJ - 

0216  14  J=J+1  I  INCREMENT  J  INDEX 

0217  GOTO  3  !  DO  FOR  NEXT  JJ 

0218 

0219  ! - END  OF  LOOP  J - 

0220  15  1=1+1  !  INCREMENT  I  INDEX 

0221  GOTO  1  !  DO  FOR  NEXT  I 

0222 

0223  ! - END  OF  LOOP  I - 

0224  16  GO  TO  999  !  RETURN  TO  CALLING  ROUTINE 

0225 

0226  ! =======  =  =  ========  ===  =  =  =  =  ===  =  =  =  ======== =GOSUB  SIMULATION=====  ====  ==== 

0227  200  T=S (N+K+2 )  !  SET  T  TO  SEG  REF  K  IN  POL  N 

0228  IF  ( ABS(T) .LE. 6)  THEN  !  VERTICAL  INTERIOR  BORDER  SEG 

0229  Y=END2(N,K)  !  LAT  OF  2ND  ENDPT  OF  K 

0230  NEGT=-T  !  OFFSET  OF  SEMENT  T 

0231  X=BCOORD ( NEGT , 2 )  !  LNG  OF  BORDER  COORDINATE 

0232  END  IF  !  END  IF  BLOCK 

0233  IF  (ABS(T) . GT . 6 . AND . ABS (T) . LE.12)  THEN  !  HORIZ  INTER  BORDER  SEG 

234  NEGT=-T  !  OFFSET  OF  SEGMENT  T 

,*235  Y=BCOORD ( NEGT , 1 )  !  LNG  OF  BORDER  COORD  OF  T 

0236  X=END2 (N,K)  !  LNG  OF  2ND  ENDPT  OF  K 


CWO.*/ 


0237  END  IF  !  END  IF  BLOCK 

0238  IF  (ABS(T) .GT.12)  THEN  !  DIGITIZED  SEGMENT 

^239  TT=S ( FNP ( -T) )  !  LAST  POINT  IN  SEGMENT  T 

0240  IF  (TT.LT.O)  GOTO  1001  !  INVALID 

0241  Y=TT/501  !  LATITUDE  OFFSET  OF  TT 

0242  X=JMOD(TT, 501)  !  INTEGER* 4  MODULO;  LNG  OFFSET 

0243  END  IF  !  END  IF 

0244  IF  (SEG.LE.6)  F= ( ABS ( X-BCOORD ( SEG, 2 ) ) . LE . TOL)  !  SET  FLAG  F 

0245  IF  (SEG.GT.6)  F= ( ABS ( Y-BCOORD( SEG , 1 ) ) . LE .TOL)  !  SET  FLAG  F 

0246  GOTO  DUM 

0248 

0249  ! - ERROR - 

0250  1001  WRITE( 5,1002)  !  INVALID  POLYGON  STRUCTURE 

0251  R= . TRUE .  !  SET  ERROR  FLAG  TO  TRUE 

0252  999  RETURN  !  RETURN  TO  CALLING  ROUTINE 

0253 

0254  ! - FORMAT  STATEMENT - 

0255  1002  FORMAT (X INVALID  POLYGON  STRUCTURE  ENCOUNTERED  IN  DNUT ' ) 

0256  END 
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0059 


SUBROUTINE  DRAW ( IXRAST , I YRAST ) 

PROLOGUE : 

MODULE  NAME:  DRAW 

AUTHOR:  J.  CASCIO,  W.  WACHTER ( FORTRAN  77),  NUSC/NL,  CODE  3333 
DATE:  1981  &  9/84  (FORTRAN  77) 

FUNCTION:  DRAW  A  VECTOR  FROM  THE  CURRENT  POSITION  KBEAMX , KBEAMY  TO 
IXRAST, IYRAST  OBSERVING  CLIPPING 
INPUTS:  LOCATION  FOR  VECTOR 
OUTPUTS:  VECTOR  DRAWN 
MODULES  CALLED:  CL IPOS,  CLIPT 
CALLED  BY:  AXIS,  BOX,  DRAWU ,  GRID,  SVPGRF 

NOTE:  THE  VECTOR  MAY  BE  MOVED  BEYOND  THE  CLIPPED  BOUNDARIES  EVEN  THOUG 
.  IT  MAY  NOT  BE  DRAWN  TO  THAT  POINT 


INCLUDE  'SCREEN. INC' 


UU  1  / 

0018 

X 

1 

1 

VARBL 

SIZE 

0019 

1 

i 

— 

0020 

1 

i 

I CL  IP 

(4) 

0021 

1 

i 

ISCLIP 

0022 

1 

i 

LENX 

0023 

1 

; 

LENY 

0024 

1 

1 

MAXX 

0025 

1 

i 

• 

MAXY 

0026 

1 

t 

• 

MINX 

0027 

1 

i 

• 

MI  NY 

-SCREEN- 


PURPOSE 

CLIP  BOUNDARIES 
.CLIPPING  FLAG 
LENGTH  OF  X  GRAPHICS 


LENGTH  OF 
MAXIMUM  X 
MAXIMUM  Y 
MINIMUM  X 
MINIMUM  Y 


BOUNDARY 
X  GRAPHICS  BOUNDARY 
GRAPHICS  BOUNDARY 
GRAPHICS  BOUNDARY 
GRAPHICS  BOUNDARY 
GRAPHICS  BOUNDARY 


TYPE 

INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2 


RANGE 


TRUE  FALSE 


1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 


INTEGER*2  ICL I P , LENX , LENY 
INTEGER* 2  MAXX,MAXY ,MINX,MINY 
INTEGER* 2  ISCLIP 

COMMON  /SCREEN/M I NX, MAXX, MI NY, MAXY, LENX, LENY, ICLIP(4) , ISCLIP 

- SCREEN  END - 

INCLUDE  ' TK4025 . INC ' 

- TK4025 - 

VARBL  SIZE  PURPOSE  TYPE  RANGE 


KBEAMX 

KBEAMY 


CURRENT  BEAM  X  POSITION 
CURRENT  BEAM  Y  POSITION 


INTEGER*2 
INTEGER* 2 


INTEGER*2  KBEAMX , KBEAMY 

COMMON/TK4 0  2  5/KBEAMX , KBEAMY 
- TK4025  END- 


VARBL  SIZE  PURPOSE 
CLIP  CLIP  FLAG 

I  PREVIOUS  COORDINATE  OUTSIDE  CLIP  FLAG 

I XI  STARTING  X  COORDINATE 

1X2  ENDING  X  COORDINATE 

IXRAST  ENDING  X  COORDINATE  IN  RASTERS 

IY1  STARTING  Y  COORDINATE 

IY2  ENDING  Y  COORDINATE 

IYRAST  ENDING  Y  COORDINATE  IN  RASTERS 

J  CURRENT  COORDINATE  OUTSIDE  CLIP  FLAG 

K  OUTSIDE  CLIP  AREA  FLAG 

L  COMPARE  CLIP  AREA  FLAG 


TYPE 

LOG I CAL *2 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
INTEGER*2 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2 


RANGE 


C-lLl 


0060  !  LI  (4)  STORE  PREVIOUS  PTS  OUT  OF  CLIP  AREA  LOGICAL*2 

0061  !  L2  (4)  STORE  CURRENT  POINTS  OUT  OF  CLIP  AREA  LOGICAL*2 

)062  ! 

0063  INTEGER* 2  I , I XI , 1X2 , IXRAST , I Y1 , IY2 , IYRAST , J ,  K,  L 

0064  LOG I CAL  *  2  CLIP , LI ( 4 ) , L2 ( 4 ) 

0065 

0066  ! - SET  UP  WHERE  THE  DRAW  VECTOR  IS 

0067  IX1=KBEAMX  !  STARTING  X  COORDINATE 

0068  IY1=KBEAMY  !  STARTING  Y  COORDINATE 

0069  1X2= IXRAST  !  ENDING  X  COORDINATE 

0070  IY2= IYRAST  !  ENDING  Y  COORDINATE 

0071  IF{IX1.EQ. IXRAST. AND. IY1.EQ. IYRAST)  GOTO  999  !  SAME  POINT,  RETU 

0072  CLIP=. FALSE.  !  INITIALIZE  CLIP  FLAG 

0073  IF  (.NOT.  ISCLIP)  GOTO  6  !  NO  CLIP  NEEDED 

0074  CALL  CL IPOS ( 1X1 , I Y1 , I , LI )  !  CHECK  WHERE  PREVIOUS  IS  OUT 

0075  CALL  CLIPOS( 1X2 , IY2 , J , L2 )  !  CHECK  WHERE  CURRENT  IS  OUT 

0076  IF  (J.NE.0)  CLIP= .TRUE .  !  SET  FLAG  FOR  AT  LEAST  SECOND  M 

0077  I F ( I . NE . 0 . AND . J . NE . 0 )  GOTO  2  !  BOTH  OUTSIDE  CLIP  AREA 

0078  I F ( I . EQ . 0 . AND . J . EQ . 0 )  GOTO  6  !  BOTH  INSIDE  CLIP  AREA 

0079  I = I I ABS ( I )  !  PREVIOUS  COORDINATE  OUTSIDE  CL 

0080  J= I I ABS ( J }  !  CURRENT  COORDINATE  OUTSIDE  CLI 

0081  CALL  CLIPT( 1X1 , IY1 , 1X2 , IY2 , I , J)  !  CLIP  LINES 

0082  GOTO  6  !  BOTH  POINTS  ARE  IN 

0083 

0084  ! - POINTS  ARE  BOTH  OUT - 

0085  2  IF ( 1 1 ABS ( I ) . EQ . 1 1 ABS ( J ) )  GOTO  8  !  IF  POINTS  IN  SAME  QUADRANT  THE 

0086  IF  ( I/3+J/3 . EQ . -1 )  GOTO  5  !  IF  PTS  IN  THE  SAME  CORNER  THEN 

0087  L=0  !  INITIALIZE 

0088  DO  3  K=1 , 4  !  DO  FOUR  TIMES 

p89  L=(L1(K)  .AND.  L2(K))+L  !  CLIPPED  AREAS  WHERE  PTS  ARE  OU 

(3090  3  CONTINUE  !  END  DO  LOOP 

0091  IF  (L.EQ.-l)  GOTO  8  !  NO  CLIP  NEEDED 

0092  IF  (L.EQ.0)  GOTO  5  !  BOTH  ENDS  NEED  TO  BE  CLIPPED 

0093  WRITE (5,4)  I  ERROR 

0094  GO  TO  999  !  RETURN  TO  CALLING  ROUTINE 

0095 

0096  ! - CLIP  BOTH  ENDS  OF  THE  VECTOR - 

0097  5  1  =  1 1 ABS ( I  )  !  CURRENT  COORDINATE  OUTSIDE  CLI 

0098  J=I IABS( J )  !  CURRENT  COORDINATE  OUTSIDE  CLI 

0099  CALL  CLIPT(IX1,IY1,IX2,IY2,I,J)  !  GET  NEW  ENDPOINTS  WITHIN  CLIP 

0100  IF  (I/3+J/3.NE.1)  GOTO  6  !  CHECK  THE  CORNER 

0101  CALL  CLIPOS(IXl, IY1,K,L1)  !  CHECK  IF  OUTSIDE  CLIP  AREA 

0102  IF  (K.NE.0)  GOTO  8  !  IF  NEW  POINT  IS  OUT  THEN  MOVE 

0103  6  WRITE (5,7)  1X1 , IY1 , 1X2 , IY2  !  DRAW  (CALCULATED)  VECTOR 

0104  8  KBEAMX= IXRAST  !  UPDATE  CURRENT  POSITION 

0105  KBEAMY= IYRAST  !  UPDATE  CURRENT  POSITION 

0106  C  IF  (CLIP)  WRITE (5,9)  KBEAMX , KBEAMY  !  COMMENTED  OUT 

0107  999  RETURN  !  RETURN  TO  CALLNG  ROUTINE 

0108 

0109  ! - FORMAT  STATEMENTS - 

0110  4  FORMAT ( '  **  ERROR  IN  ''DRAW'*,  IMPOSSIBLE  CLIP  BOUNDARIES') 

0111  7  FORMATC  !  VEC '  ,  4  ( X ,  1 3  )  ) 

0112  9  FORMATC  !  VEC  '  ,  1 3  ,  X ,  1 3  ) 

0113  END 


0001 
0002 
0003 
0004 
0005 
0006 
0007 
0008 
0009 
0010 
0011 
0012 
0013 
0014 
0015 
0016 
0017 
0018 
0019 
0020 
0021 
0022 
0023 
0024 
0025 
0026 
0027 
0028 
0029 
*330 
<f0  3 1 
0032 
0033 
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0035 
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0037 
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0040 
0041 
0042 
0043 


SUBROUTINE  DUPDEP ( NBT , D , VEL ) 


PROLOGUE: 

MODULE  NAME:  DUPDEP 

AUTHOR:  S.  LAFLEUR  &  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  1983  &  11/83  (FORTRAN  77) 

FUNCTION:  SUBROUTINE  DUPDEP  ELIMINATES  DUPLICATE  CONSECUTIVE  DEPTHS 
AND  DEPTHS  WHICH  ARE  NOT  IN  ASCENDING  ORDER. 

INPUTS:  PARAMETERS  PASSED  IN. 

OUTPUTS:  MODIFIED  PARAMETERS  PASSED  OUT. 

MODULES  CALLED:  NONE 
CALLED  BY:  ENVIRN , FORCST , XBT 


TYPE  RANGE 


REAL *4 
REAL *4 
INTEGER* 2 
INTEGER*2 
INTEGER* 2 
INTEGER *2 
REAL* 4 

INTEGER* 2  I , J ,NBT , NDLYR 
REAL *4  D, DLYR, VEL 

DIMENSION  D( 1) ,VEL{ 1) 


VARBL 

SIZE 

PURPOSE 

D 

(25) 

DEPTH 

DLYR 

LAYER  DEPTH 

I 

COUNTER 

J 

COUNTER 

NBT 

NUMBER  OF  BT  POINTS 

NDLYR 

POE  I TON  OF  BT  LAYER 

VEL 

(25) 

VELOCITY 

I  =  1 

10  IF(I.LE.NBT-l)  THEN 

IF(D( I ) .GE.D( 1+1) )  THEN 
DO  50  J  =  1+1 ,NBT-1 
D ( J )  =  D( J+l ) 

VEL(J)  =  VEL { J  + 1 ) 

50  CONTINUE 

1  =  1-1 
NBT  =  NBT  -  1 
END  IF 
1  =  1+1 
GOTO  10 
.  END  IF 


INITIALIZE  COUNTER 
IF  <  NEXT  TO  LAST  BT 
NOT  IN  ASCENDING  ORDER 
ELIMINATE  POINT  AT  1+1  BY 
MOVING  DEPTH  VALUES  UP  ONE 
&  MOVING  VEL  VALUES  UP  ONE 
END  DO  LOOP 
DECREASE  COUNTER 
DECREASE  NUMBER  OF  BTS 
END  IF  BLOCK 
INCREASE  COUNTER 
START  AGAIN 
END  IF  BLOCK 


RETURN 

END 


!  RETURN  TO  CALLING  ROUTINE 
!  END  SUBROUTINE 


C-llJ 


0001 

0002 

p003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 

0011 

0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 

0021 

0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

p30 

j031 

0032 

0033 

0034 

0035 

0036 


SUBROUTINE  DUPVEL ( NBT , D , VEL ) 


PROLOGUE : 

MODULE  NAME:  DUPVEL 

AUTHOR:  S.  LAFLEUR  &  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  5/84  &  5/84  (FORTRAN  77) 

FUNCTION:  SUBROUTINE  DUPVEL  ELIMINATES  DUPLICATE  CONSECUTIVE 
SOUND  SPEEDS 

INPUTS:  PARAMETERS  PASSED  IN. 

OUTPUTS:  MODIFIED  PARAMETERS  PASSED  OUT. 

MODULES  CALLED:  NONE 
CALLED  BY:  ENVIRN, FORCST ,XBT 

VARBL  SIZE  PURPOSE  TYPE  RANGE 


REAL *4 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
REAL *4 

INTEGER* 2  I DONE, J, NBT 
REAL *4  D, VEL 

DIMENSION  D( 1 ) , VEL ( 1 ) 


D  (25)  DEPTH 

I DONE  FLAG 

J  COUNTER 

NBT  NUMBER  OF  BT  POINTS 

VEL  (25)  VELOCITY 


10  I DONE 


INITALIZE  FLAG 


DO  50  J=2 ,NBT  !  FOR  NUMBER  OF  BT 

I F ( VEL ( J ) . EQ . VEL ( J- 1 ) )  IDONE=0  !  RESET  FLAG 
I F ( VEL ( J ) . EQ. VEL ( J-l ) )  VEL ( J ) =VEL ( J ) +0 . 0 1  !  RESET  VEL 
50  CONTINUE  !  END  DO  LOOP 


I F ( I DONE . EQ . 0 )  GOTO  10 


!  REPEAT 


RETURN 

END 


!  RETURN  TO  CALLING  ROUTINE 
!  END  SUBROUTINE 


C-(3,l 


0001 
0002 
P  0  0  3 
0004 
0005 
0006 
0007 
0008 
0009 
0010 
0011 
0012 
0013 
0014 
0015 
0016 
0017 
0018 
0019 
0020 
0021 
0022 
0023 
0024 
0025 
0026 
0027 
0028 
0029 
)030 
0031 
0032 
0033 
0034 
0035 
0036 
0037 
0038 
0039 
0040 
0041 
0042 
0043 
0044 
0045 
0046 
0047 
0048 
0049 
0050 
0051 
0052 
0053 
0054 
0055 
0056 
)057 
0058 
0059 


SUBROUTINE  EDITBT { INSSP , NBT , D , TVEL ) 


PROLOGUE : 

MODULE  NAME:  EDITBT 

AUTHOR:  G.  BROWN  S<  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  1974  &  12/83  (FORTRAN  77) 

FUNCTION:  SUBROUTINE  EDITBT  ALLOWS  THE  OPERATOR  EDIT  BT  DATA. 
INPUTS:  OPERATOR  SELECTION  TO  UPDATE  PARAMETERS  OR  NOT. 
VARIABLES  PASSED  IN. 

OUTPUTS:  CRT  PROMPTING  MESSAGES  TO  OPERATOR. 

MODULES  CALLED:  ICLR 
CALLED  BY:  BT , KEYPCH 

VARBL  SIZE  PURPOSE  TYPE  RANGE 


D 

I 

INSSP 

J 

K 

LI 

M 

NBT 

N4 

TVEL 


DEPTH  MATRIX 
COUNTER 
INPUTED  SSP 
COUNTER 
COUNTER 

LINE  NUMBER  FOR  CHANGE 
NUMBER  OF  BT  +  1 
NUMBER  OF  DEPTH/TEMP  PAIRS 
TYPE  OF  CORRECTION 
TEMPERATURE  MATRIX 


REAL*4 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2  1,2,3 

REAL *4 


INTEGER*2  I , INSSP , J , K , LI , M, NBT , N4 
REAL *4  D , TVEL 

DIMENSION  D( 1 ) , TVEL( 1 ) 


- PRELIMINARIES - 

10  CALL  ICLR  !  CLEAR  SCREEN 

WRITE( 5 , 1200 )  !  WRITE  TITLES 

DO  15  1=1, NBT  !  FOR  ALL  BT  POINTS 

WRITE  (.5,1230  )  I  ,  D(  I )  ,  TVEL  (  I  )  !  WRITE  DEPTH,  TEMP,  SS 
15  CONTINUE  !  END  DO  LOOP 

M=NBT+1  !  M  IS  NUMBER  OF  BT  +  1 


WRITE(5, 1010)  M 
WRITE( 5,1020) 

READ (5,1050)  LI 
IF(Ll.EQ.O)  GO  TO  370 
IF(Ll.LT.l.OR.Li.GT.M)  GO  TO 
20  WRITE( 5,1100) 

READ (5,1150)  N4 
IF (N4 . LT . 1 . OR. N4 .GT. 3 )  GO 

IF(N4.EQ.l)  THEN 
IF(Ll.NE.NBT)  THEN 

IF(Ll.GT.NBT)  GO  TO  10 
K=NBT-1 
DO  130  J=L1 ,K 
D( J) =D( J+l ) 

TVEL ( J ) =TVEL ( J+ 1 ) 

130  CONTINUE 

END  IF 
D( NBT ) =0 . 

TVEL (NBT) =0 . 


— CORRECTION - 

!  INPUT  LINE  NUMBER  FOR  CHANGE 
I  INPUT  LINE  NUMBER  FOR  CHANGE 
!  LINE  NUMBER  FOR  CHANGE 
!  NO  CHANGES  WANTED,  RETURN 
10!  INVALID  LINE  £,  TRY  AGAIN 
!  INPUT  TYPE  OF  CORRECTION 
!  TYPE  OF  CORRECTION 
20!  INVALID,  ASK  AGAIN 

!  DELETE  AN  ENTRY 
!  NOT  LAST  ENTRY 
!  GREATER  THAN  LAST,  TRY  AGAIN 
!  K  IS  NUMBER  OF  BT  -  1 
!  MOVE  EACH  ARRAY  VALUE  UP  ONE 
!  DEPTH 
!  TEMPERATURE 

!  THIS  DELETES  ENTRY  AT  LI  BY 
!  WRITING  OVER  IT 
!  ZERO  OUT  LAST  DEPTH  ENTRY 
!  ZERO  OUT  LAST  TEMP  ENTRY 


C-t'-u 


0060 

Q061 

)062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

330 

0079 

0080 

0081 

0082 

0083 

0084 

0085 

0086 

0087 

370 

\088 

X)39 

!  *** 

0090 

1010 

0091 

0092 

1100 

0093 

0094 

0095 

0096 

1020 

0097 

1050 

0098 

1150 

0099 

1200 

0100 

0101 

1230 

0102 

1300 

0103 

1330 

0104 

1350 

0105 

NBT = NBT -1 
END  IF 

IF ( N4 . EQ . 2 )  THEN 

IF(Ll.GT.NBT)  GO  TO  10 
WRITE ( 5 , 1300 ) 

READ (5,1330)  D(L1) 
WRITE (5,1350) 

READ (5, 1330)  TVEL(Ll) 
END  IF 


DECREASE  #  OF  BT  BY  ONE 
END  IF  BLOCK 

CHANGE  AN  ENTRY 

GREATER  THAN  LAST,  TRY  AGAIN 

INPUT  DEPTH 

REVISED  DEPTH 

INPUT  TEMPERATURE 

REVISED  TEMPERATURE 

CHANGED  BY  WRITTING  OVER  OLD 


IF (N4 . EQ. 3 )  THEN 

IF( INSSP . NE . 5 . AND . NBT . GE . 2  5 ) 
I F ( INSSP . EQ . 5 . AND . NBT . GE . 5  0 ) 
IF(Ll.NE.M)  THEN 
DO  330  K=M , LI , -1 
D(K) =D(K-1 ) 

TVEL(K) =TVEL(K-1 ) 
CONTINUE 
END  IF 

WRITE (5 ,1300 ) 

READ (5,1330)  D(L1) 

WRITE (5,1350) 

READ (5,1330)  TVEL(Ll) 
NBT=NBT+1 
END  IF 
GO  TO  10 
RETURN 


!  ADD  AN  ENTRY 
GO  TO  10  !  >  MAX,  TRY  AGAIN 
GO  TO  10  !  >  MAX,  TRY  AGAIN 
!  NOT  EQUAL  TO  LAST 
!  MOVE  ARRAY  VALUES  DOWN  ONE 
!  MOVE  DEPTH  VALUES 
!  MOVE  TEMP  VALUES 
!  MOVING  VALUES  DOWN  ONE  ALLOWS 
!  ROOM  FOR  NEW  ENTRY  AT  LI 
!  INPUT  DEPTH 
1  REVISED  DEPTH 
!  INPUT  TEMPERATURE 
!  REVISED  TEMPERATURE 
!  INCREASE  #  OF  BT  BY  1 
!  END  IF  BLOCK 
!  START  AGAIN 

!  RETURN  TO  CALLING  ROUTINE 


FORMAT  STATEMENTS - 

FORMAT (//, T20, ' ****ENTER  LINE  NOS.  1  -',12,'  FOR  CHANGES****' 
/1H  , T2C , ' ****ENTER  EXTRA  (CR)  FOR  END  OF  EDIT****') 

FORMAT (1H  /T20, 'TYPES  OF  CORRECTION’ 

/1H  , T 2 C , ' 1  =  DELETE  ENTRY' /1H  ,T20,'2  =  CHANGE  ENTRY' 

/1H  , T 2 3 ,  '3  =  INSERT  NEW  ENTRY  BEFORE  LINE  INDICATED' 
//1H$,T24, 'ENTER  TYPE  OF  CORRECTION  (X)',T65,’  ') 

FORMAT ( 1H  /1H$ ,T24, 'ENTER  LINE  NUMBER  (XX)',T65,'  ') 

FORMAT (12) 

FORMAT (II) 

FORMAT (1H  /T20, 'NO. ' ,T29, 'DEPTH' ,T42, 'TEMP' 

/T43 , ' OR ' /T4  2 ,  ' SOUND '/T42, 'SPEED'/) 

FORMAT (T20 ,I2,2(5X,F7.1)) 

FORMAT ( 1H  /1H$ ,T24, 'ENTER  DEPTH  (ONE  DECIMAL  PLACE )’, T65 , '  ') 
FORMAT (F10.0) 

FORMAT ( 1H  /1H$ ,T24 , 'ENTER  TEMP  (ONE  DECIMAL  PLACE )', T65 , '  ') 

END 


c- ( V.  TL 
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0002 
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0059 


INTEGER* 2  FUNCTION  END1(I,J) 

PROLOGUE : 

MODULE  NAME:  END1 

AUTHOR:  E.  PETRI DES  Sc  P.  FRAGEORGIA  OF  SYSCON,  INC 

RECODED:  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  1982  Sc  6/84  (FORTRAN  77) 

FUNCTION:  SUBROUTINE  ENDPOINT  #1  WILL  DETERMINE  EITHER  THE 
DISTANCE  OF  THE  X  OR  Y  DISTANCE  OF  THE  FIRST 
ENDPOINT  OF  SEGMENT  J  OF  POLYGON  I. 

INPUTS:  VARIABLES  NEEDED  TO  CALCULATE  DISTANCE 
OUTPUTS:  X  OR  Y  DISTANCE  OF  THE  FIRST  ENDPOINT  OF  J 
MODULES  CALLED:  BMOD ,  FNP ,  KMOD 
CALLED  BY:  CNNCT ,  DNUT ,  PD I  ST 


INCLUDE  'MAP. PAR' 

1  PARAMETER  STOLEN=3800 

1  PARAMETER  SEGLEN=60 ,  POLLEN=40 

1  PARAMETER  WRKLEN=1000,  NDXLEN=30Q 

1  PARAMETER  MAXDT Y  =  3 

1  PARAMETER  TOL=3 

1  PARAMETER  DEG=57 . 2957795 

1  PARAMETER  RAD= . 017453293 

1  PARAMETER  PI=3 . 14159265 

1  PARAMETER  ERAD=3440.3 

1  PARAMETER  S251=63001 

1  PARAMETER  TW015=32768 

1 

1  !  INTEGER* 2  MAXDTY , NDXLEN , POLLEN, SEGLEN, STOLEN, TOL , WRKLEN 

1  !  INTEGER*4  S251,TW015 

1  !  REAL *4  DEG , ERAD , P I , RAD 

INCLUDE  ' CBC2 . INC ' 

1  !  - CBC2.INC - 

1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

1  !  BCOORD  (25,2) 

1  ! 

1  I NTEGER* 2  BCOORD (25,2) 

1 

1  COMMON  /CBC/  3C00RD 

1  ! - END  CBC2.INC - 

1 

INCLUDE  'CS. INC' 

1  !  - CS - 

1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

1  !  S  -1,3800  POLYGON  AND  SEGMENT  STORAGE  ARRAY  REAL *4 

1  !  STOLEN  STORAGE  ARRAY  LENGTH  (FOR  SEGS  S<  POLYS)  PARM 

1  ! 

1  REAL *4  S(-l: STOLEN) 

1 

1  COMMON  /CS/  S 

1  i - CS-END - 

1 


VARBL  SIZE  PURPOSE  TYPE  RANGE 


BMOD  FUNCTION 

FNP  FUNCTION 


I NTEGER* 2 
I  NTEGER* 2 


0060 

0061 

)062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 

0081 

0082 

0083 

0084 


!  I  CURRENT  POLYGON  INTEGER* 2 

!  J  CURRENT  SEGMENT  IN  POLYGON  I  INTEGER* 2 

!  K  SEGMENT  PRECEDING  J  INTEGER*2 

!  KMOD  FUNCTION  INTEGER* 2 

i 

!  ***  VARIABLES  NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMONS  *** 

INTEGER *2  FNP , I , J , K , KMOD 
REAL *4  BMOD 

END1=-1  !  INTIALIZE  ENDPOINT  #1 

K=-S ( 1+ ( KMOD (J- 2 ,IIFIX(S(l+l) ) ) +1 ) +2 ) !  SEGMENT  PRECEDING  J 
IF  (ABS(K) .LE.12)  THEN  !  INTERIOR  BORDER  SEGMENT 

IF  (ABS(S( I+J+2) ) .LE.12. )  ENDl=BCOORD ( K+13 , 2 )  !  HORIZONTAL 
IF  (ABS(S( I+J+2) ) .LE.6. )  ENDl=BCOORD( K+13 , 1 )  !  VERTICAL 

ELSE  !  BORDER  SEGMENT 

IF  (ABS(S(I+J+2)) .LE.12.)  END13 I IFIX( BMOD( S ( FNP (K) ) , 50 1 ) ) ! HOR 
IF  (ABS(S( I+J+2) ) .LE.6. )  END1=I IF IX( S ( FNP ( K) ) /501 )  !  VERTICAL 
END  IF  !  END  IF  BLOCK 

IF  (END1.EQ.-1)  WRITE( 5,102)  !  ERROR  MESSAGE 

RETURN  _  !  RETURN  TO  CALLING  ROUTINE 

! - FORMAT  STATEMENT - 

102  FORMAT ( X PROGRAM  ERROR,  ATTEMPT  TO  USE  END1  ON  NON-BORDER') 

END 


COMMAND  QUALIFIERS 

FORTRAN  /CHECK3 ALL/LI  ST/SHOW3 ( INCLUDE, NOMAP)  [ LAFLEUR] END1 . F77 

/CHECK= ( BOUNDS , OVERFLOW , UNDERFLOW ) 

/DEBUG3 ( NOSYMBOLS , TRACEBACK ) 

/STANDARD3 ( NOSYNTAX , NOSOURCE_FORM ) 

/SHOW= ( NOPREPROCESSOR , I NCLUDE , NOMAP ) 

/F77  /NOG  FLOATING  /1 4  /OPTIMIZE  /WARNINGS  /NOD  LINES  /NOCROSS  REFERENCE 


COMPILATION  STATISTICS 


Run  Time: 
Elapsed  Time: 
Page  Faults: 
Dynamic  Memory: 


1.32  seconds 
4.48  seconds 
351 

135  pages 


C-  (T.  z. 


0001 
0002 
6003 
0004 
0005 
0006 
0007 
0008 
0009 
0010 
0011 
0012 
0013 
0014 
0015 
0016 
0017 
0018 
0019 
0020 
0021 
0022 
0023 
0024 
0025 
0026 
0027 
0028 
0029 
20  30 
0031 
0032 
0033 
0034 
0035 
0036 
0037 
0038 
0039 
0040 
0041 
0042 
0043 
0044 
0045 
0046 
0047 
0048 
0049 
0050 
0051 
0052 
0053 
0054 
0055 
9056 
J  057 
0058 
0059 


INTEGER*2  FUNCTION  END2(I,J) 

!  PROLOGUE: 

!  MODULE  NAME:  END2 

!  AUTHOR:  E.  PETRI DES  &  P.  FRAGEORGI A  OF  SYSCON,  INC 
!  RECODED:  W.  WACHTER,  CODE  3333,  NUSC/NLL 
!  DATE:  1982  &  6/84  (FORTRAN  77) 

!  FUNCTION:  SUBROUTINE  ENDPOINT  #2  WILL  DETERMINE  EITHER 
!  THE  X  OR  Y  DISTANCE  OF  THE  LAST  ENDPOINT  OF 

!  SEGMENT  J  OF  POLYGON  I . 

!  INPUTS:  VARIABLES  NEEDED  TO  CALCULATE  DISTANCE 
1  OUTPUTS:  THE  X  OR  Y  DISTANCE  OF  THE  LAST  ENDPOINT  OF  J 
!  MODULES  CALLED:  BMOD ,  FNP ,  KMOD 
!  CALLED  BY:  CNNCT ,  DNUT ,  PD I ST 

i 

INCLUDE  'MAP. PAR' 

1  PARAMETER  STOLEN=3800 

1  PARAMETER  SEGLEN=60 ,  POLLEN=40 

1  PARAMETER  WRKLEN=1000,  NDXLEN=300 

1  PARAMETER  MAXDT Y  =  3 

1  PARAMETER  TOL=3 

1  PARAMETER  DEG=57 . 2957795 

1  PARAMETER  RAD= . 017453293 

1  PARAMETER  PI-3 . 14159265 

1  PARAMETER  ERAD=3440.3 

1  PARAMETER  S251=63001 

1  PARAMETER  TW015=32768 

1 

1  !  INTEGER* 2  MAXDTY , NDXLEN , POLLEN, SEGLEN , STOLEN , TOL , WRKLEN 

1  !  INTEGER* 4  S251,TW015 

1  !  REAL *4  DEG , ERAD , P I , RAD 

INCLUDE  ' CBC2 . INC ' 

1  I  - CBC2.INC - 

1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

1  !  BCOORD  (25,2) 


1  ! 

1  INTEGER* 2  BCOORD (2 5, 2) 

1 

1  COMMON  /CBC/  BCOORD 

1  j - END  CBC2.INC - 

1 

INCLUDE  ' CS . INC ' 

1  !  - CS - 

1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

1  !  S  -1,3800  POLYGON  AND  SEGMENT  STORAGE  ARRAY  REAL *4 

1  !  STOLEN  STORAGE  ARRAY  LENGTH  (FOR  SEGS  &  POLYS)  PARM 

1  ! 

1  REAL* 4  S(-l: STOLEN) 

1 

1  COMMON  /CS/  S 

1  ! - CS-END - 

1 

I 

!  VARBL  SIZE  PURPOSE  TYPE  RANGE 

!  BMOD  FUNCTION  REAL *4 

!  FNP  FUNCTION  INTEGER* 2 


r-(t ./ 


0060 

0061 

)062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 

0081 

0082 

0083 

0084 


I 

CURRENT  POLYGON 

INTEGER* 2 

J 

CURRENT  SEGMENT  OR  POLYGON  I 

INTEGER*2 

K 

SEGMENT  SUCCEEDING  J 

INTEGER* 2 

KMOD 

FUNCTION 

INTEGER* 2 

***  VARIABLES 

NOT  LISTED  HERE  SHOULD  APPEAR 

IN  COMMONS  *** 

INTEGER* 2  FNP , I , J , K , KMOD 
REAL *4  BMOD 


END2=-1  !  INITIALIZE  ENDPOINT  #2 

K3  S ( I + ( KMOD (J,IIFIX(S{I+1) ) )+l)+2) !  SEGMENT  SUCCEEDING  J 
IF  (ABS(K) .LE.12)  THEN  !  INTERIOR  BORDER  SEGMENT 

IF  (ABS(S( I+J+2) ) .LE.12. )  END2=BCOORD(K+13 , 2 )  !  HORIZONTAL 
IF  (ABS(S(I+J+2)).LE.6.)  END2=BCOORD (K+l 3 , 1 )  !  VERTICAL 

ELSE  !  BORDER  SEGMENT 

IF  (ABS(S( I+J+2) ) .LE.12. )  END2= I IFIX( BMOD( S ( FNP(K) ) , 501 ) ) ! HOR 
IF  (ABS(S{ I+J+2) ) .LE.6. )  END2= I IFIX( S ( FNP (K) )/501)  !  VERTICAL 
END  IF  !  END  IF  BLOCK 

IF  (END2.EQ.-1)  WRITE(5,102)  !  ERROR  MESSAGE 

RETURN  !  RETURN  TO  CALLING  ROUTINE 

I - FORMAT  STATEMENT - 

102  FORMAT ( X PROGRAM  ERROR,  ATTEMPT  TO  USE  END 2  ON  NON-BORDER') 

END 


COMMAND  QUALIFIERS 

FORTRAN  /CHECK=ALL/L I ST/SHOW=( INCLUDE, NOMAP)  [ LAFLEUR] END2 . F77 

/CHECK = ( BOUNDS , OVERFLOW , UNDERFLOW ) 

/DEBUG3 ( NOSYMBOLS , TRACEBACK ) 

/STANDARD3 ( NOSYNTAX , NOSOURCE_FORM ) 

/SHOW3 ( NOPREPROCESSOR , INCLUDE , NOMAP ) 

/F77  /NOG  FLOATING  /I4  /OPTIMIZE  /WARNINGS  /NOD  LINES  /NOCROSS  REFERENCE 


COMPILATION  STATISTICS 


Run  Time: 
Elapsed  Time: 
Page  Faults: 
Dynamic  Memory 


1.23  seconds 
10.02  seconds 
349 

135  pages 


C-ti.  2. 


14-Dec-1984  08 s 31: It 
14-Dec-1984  08:31:1! 


0001  SUBROUTINE  ENVIRN( IPRINT) 

T 

0004 
0005 
0006 
0007 
0008 
0009 
0010 
0011 
r  0012 
0013 
0014 
-  0015 


0016  INCLUDE  ' DHST .  INC ' 

0  017  1  ! - DHST - 

0018  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0019  1  !  - -  -  - 

0020  1  !  SCHNLD  SOUND  CHANNEL  LAYER  DEPTH  REAL* 4 

0021  1  1 

0022  1  REAL*4  SCHNLD 

0023  1 

0024  1  COMMON  /DHST /  SCHNLD 

0025  1  ! - DHST  END - 

0026  INCLUDE  'DTV. INC' 

0027  1  ! - DTV - 

0028  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

,  0*29  1  !  - -  -  -  - 

)0  1  I  D  (25)  DEPTH  REAL*4 

0031  1  l  DD  (25)  DEPTH  REAL*4 

0032  1  !  NNBT  NUMBER  OF  BATHETHERMAL  INTEGER* 2 

0033  1  !  T  (25)  TEMPERATURE  REAL*4 

0034  1  !  TT  (25)  TEMPERATURE  REAL*4 

0035  1  !  VEL  (25)  VELOCITY  REAL*4 

0036  1  i 

0037  1  INTEGER* 2  NNBT 

0038  1  REAL*4  D ,DD,T,TT,VEL 

0039  1 

0040  1  COMMON  /DTV/  D( 25 ) ,T( 25) ,VEL (25) ,DD( 25) ,TT( 25) ,NNET 

0041  1  ! - END  DTV - 

0042  INCLUDE  'ENVN.INC' 

.  0043  1  ! - ENVN - 

0044  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0045  1  !  - -  -  -  - 

0046  1  !  BIO  (2)  BIOLOGICAL  BACK  SCATTERING  REAL* 4  -57.  &  -47. 

0047  1  !  DLYR  LAYER  DEPTH  REAL* 4 

0048  11  MGS  MGS  PROVINCE  INTEGER* 2 

0049  1 

0050  1  REAL* 4  BIO, DLYR 

0051  1  INTEGER*2  MGS 

0052  1  DATA  BIO/ -57. ,-47. / 

0053  1 

0054  1  COMMON  /ENVN/  BIO ( 2 ) ,DLYR ,MGS 

0055  1 

0*56  1  ! - END  ENVN - 

v  J7  INCLUDE  ' GRF . INC ' 


PROLOGUE: 

MODULE  NAME:  ENVIRN 

AUTHOR:  SUNG  KO ,  S.  LAFLEUR  &  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  1974,  1983  (REDESIGN),  &  12/83  (FORTRAN  77) 

FUNCTION:  SUBROUTINE  ENVIRN  IS  USED  TO  OBTAIN  LOCAL  ENVIRNMENTAL 
PARAMETERS  WHICH  ARE  COMBINED  WITH  HISTORICAL  DATA  FOR 
THE  AREA  AND  MONTH. 

INPUTS:  PARAMETERS  PASSED  IN.  VARIABLES  IN  COMMONS. 

OUTPUTS:  CRT  PROMPTING  MESSAGES  TO  OPERATOR. 

MODULES  CALLED:  BT,DUPDEP,DUPVEL,ICLR, INSERT, KEYPCH, LAYER, MAP, 
NOCONV , SVFGRF , VELTMP , XBT 
CALLED  BY:  SIMAS 


017./ 


ENVIRN 


0058  1  l 

r  \S  11 

t  .60  1  ! 

0061  1  ! 
0062  1  I 

0063  1  ! 

0064  1  1 

0065  1  S 

0066  1  ! 
0067  1  ! 

0068  1 
0069  1 

0070  1 

0071  1 

0072  1 

0073  1 

0074  1  ! 

0075 

0076  1  t 

0077  1  ! 

0078  1  ! 

0079  1  S 

0080  1  ! 
0081  1  ! 
0082  1  I 

0083  1  ! 

0084  1  ! 

0  085  1 


0088  1 
0089  1 

0090  1 

0091  1 

0092  1 

0093 
0094  1 

0095  1 

0096  1 

0097  1 

0098  1 

0099  1 

0100  1 
0101  1 
0102  1 
0103  1 

0104  1 

0105  1 

0106  1 
0107  1 

0108  1 
0109  1 

0110  1 
0111  1 
0112  1 


14-Dec-1984  08s31sl€ 
14-Dec-19B4  08:31slE 


VARBL 

SIZE 

- GRF - 

PURPOSE 

TYPE 

RANGE 

DBT 

(25) 

DEPTH  OF  DEPTH /VEL  PAIR 

REAL* 4 

TANS 

PREDICTION  TYPE 

INTEGER* 2 

-2  TO  +2 

ILYR 

INBT 

ISVP 

INDEX  FOR  LAYER  DEPTH 

OPERATOR  ENTERED  #  OF  BT  POINTS 
LATEST  OR  HISTORICAL  BT  FLAG 

INTEGER* 2 
INTEGER* 2 
INTEGER* 2 

1  OR  2 

12000 

VBT 

(25) 

SVP  INDEX  FOR  2000  FT  DEPTH 
VELOCITY  FOR  DEPTH  PAIR  REAL*4 

INTEGER* 2 
REAL* 4 

REAL* 4 

DBT, VBT 

INTEGER*2  IANS , ILYR , INBT , ISVP , 12000 

COMMON  /GRF/  IANS , ISVP , ILYR , 12000 , INBT,DBT( 25 ) ,VBT( 25 ) 


- END  GRF - 

INCLUDE  'LOC. INC' 

- LOC - 

VARBL  SIZE  PURPOSE  TYPE  RANGE 


INDX  SSP  INDEX  INTEGER* 2 

LAT  (4)  LATITUDE  INTEGER* 2 

LONG  (4)  LONGITUDE  INTEGER* 2 

NMAREA  (20)  AREA  OCEAN  NAME  BYTE 

NOC  NUMBER  OF  OCEAN  INTEGER* 2 

RCZ  RANGE  TO  CONVERGE  ZONE  REAL *4 

REAL* 4  RCZ 

INTEGER*2  INDX , LAT, LONG , NOC 
BYTE  NMAREA (20) 

COMMON  /LOC/  LAT ( 4 ) , LONG ( 4 ) , NOC , INDX , RCZ , NMAREA 


- END  LOC 

INCLUDE  ' SVP. INC' 
- SVP--- 


VARBL 

SIZE 

PURPOSE 

TYPE 

RANGE 

BDF 

BOTTOM  DEPTH  IN  FATHOMS 

REAL* 4 

BIOP 

BIOLOGICAL  BACK  SCATTERING  COEF 

REAL*4 

BTDATE 

(9) 

DATE  OF  LAST  BT  INPUT 

BYTE 

BTTIME 

(8) 

TIME  OF  LAST  BT  INPUT 

BYTE 

C 

(50) 

VELOCITY  (PAIRED  WITH  Z  FOR  SVP) 

REAL*4 

CC 

(  50) 

VELOCITY  (PAIRED  WITH  ZZ  FOR  SVP)REAL*4 

CS 

SOUND  VELOCITY  AT  SURFACE 

REAL*4 

DEG 

TEMPERATURE  (DEG) 

REAL*4 

57.2957795 

EL 

LAYER  DEPTH 

DATA 

F 

FREQUENCY 

REAL *4 

GRDS 

GRIDS 

REAL* 4 

0.0164 

ITO 

MINIMAL  2 -WAY  TRAVEL  TIME 

INTEGER* 2 

MGS  OP 

MGS  PROVINCE  NUMBER 

INTEGER* 2 

N 

#  OF  DEPTH/VELOCITY  PAIRS 

INTEGER* 2 

NN 

#  OF  DEPTH/ VELOCITY  PAIRS 

INTEGER* 2 

PI 

MATHEMATICAL  CONSTANT  PI 

REAL*4 

3.1415927 

SNDATE 

(9) 

DATE  SYS  PARMS  LAST  UPDATED 

BYTE 

SNTIME 

(8) 

TIME  SYS  PARMS  LAST  UPDTAED 

BYTE 

c-n.i 


ENVIRN 


14-Dec-1984  08:31:lt 
14-Dec-1984  08:31:15 


0115  1 

r>16  1 
v.  JL7  1 
0118  1 
0119  1 

0120  1 
0121  1 
0122  1 
0123  1 

0124  1 

0125  1 

0126  1 
0127  1 

0128  1 
0129  1 

0130  1 

0131  1 

0132  1 

0133  1 

0134  1 

0135 
0136  1 

0137  1 

0138  1 

0139  1 

0140  1 

0141  1 

0142  1 

r-43  1 

44  1 

0145  1 

0146  1 

0147  1 

0148  1 

0149  1 

0150  1 

0151  1 


SYDATE  (9) 
SYTIME  (8) 
TMP 
UMKZ 
WS 

Z  (50) 

ZZ  (50) 


CURRENT  DATE  READ  FROM  SYSTEM  BYTE 

CURRENT  TIME  READ  FROM  SYSTEM  BYTE 

TEMPERATURE  REAL* 4 

BOTTOM  BACK  SCATTERING  COEF.  REAL*4 

WIND  SPEED  REAL* 4 

DEPTH  OF  POINT  OF  SOUND  SPEED  REAL* 4 

DEPTH  OF  POINT  OF  SOUND  SPEED  REAL*4 


-28.0 


INTEGER* 2  ITO , MGS OP ,N ,NN 

REAL*4  BDF,BIOP,C( 50) ,CC(50) ,CS ,DEG,EL,F,GRDS 

REAL*4  PI ,TMF ,UMKZ , WS , Z ( 50 ) ,ZZ(50) 

BYTE  SYDATEO)  ,SYTIME(8)  , BTDATE (  9  )  ,BTTIME(  8) 

BYTE  SNDATE (  9 )  , SNTIME ( 8 ) 

DATA  PI, DEG, GRDS/ 3. 1415927 ,57.2957795,0. 0164/ 

DATA  UMKZ/ -28./ 


COMMON  /SVP/  F,N, Z , C ,EL ,MGSOP , BDF , WS , CS ,TMP ,BIOP , 

1  UMKZ, PI, DEG, GRDS, ITO, ZZ,CC,NN, 

2  SYDATE, SYTIME, BTDATE, BTTIME, SNDATE, SNTIME 

- SVP-END - 

INCLUDE  ' SVP1 . INC ' 

- SVP1 - 

VARBL  SIZE  PURPOSE  TYPE  RANGE 


BUFFER  (224) 

DS  (30) 

J20 

NS 

NSN 

SLNTY 

VS  (30) 


HISTORICAL  DATA  FILE  BUFFER  REAL*4 

HISTORICAL  DEPTH  REAL*4 


#  OF  DEEP  OCEAN  DEPTH /VEL  PAIRS  INTEGER* 2 
TOTAL  #  OF  PAIRS  IN  HISTORICAL  INTEGER* 2 

MONTH  NUMBER  (1=JAN.,ETC)  INTEGER* 2 

SALINITY  REAL*4 

HISTORICAL  VELOCITY  REAL*4 


1  TO  12 


REAL* 4  BUFFER, DS, SLNTY, VS 

INTEGER* 2  J20,NSN,NS 

COMMON  /SVP1/  J20 , BUFFER ( 224 ) , NSN, SLNTY, DS ( 30 ) ,VS ( 30 ) ,NS 
- end  SVP1 - 


0152 

0153 

1 

!  VARBL 

SIZE 

PURPOSE 

TYPE 

0154 

i - - 

— 

— 

0155 

!  I 

COUNTER 

INTEGER* 2 

0156 

!  IDD 

DAY  IN  DATE 

INTEGER* 2 

0157 

!  IFIN 

POINTER  FINISH  OF  IROC  ARRAY 

INTEGER* 2 

0158 

l  IPRINT 

PRINT  FILE  FLAG 

INTEGER* 2 

0159 

!  IROC 

(15) 

ARRAY  WITH  NNAMES  OF  OCEANS 

INTEGER* 2 

0160 

!  INPBDF 

INPUTTED  BOTTOM  DEPTH  (FATHOMS) 

INTEGER* 2 

0161 

‘  INSSP 

SSP  ENTRY  TYPE  -  MANUAL  OR  HIST 

INTEGER* 2 

0162 

!  ISTR 

POINTER  START  IN  IROC  ARRAY 

INTEGER*! 

0163 

!  IYY 

YEAR  IN  DATE 

INTEGER* 2 

0164 

i  J 

COUNTER 

INTEGER* 2 

0165 

!  JANS 

OPERATOR  RESPONSE 

INTEGER* 2 

0166 

!  K 

COUNTER 

INTEGER*! 

0167 

I  MAPFLG 

FLAG  FOR  MAP  FORM  TASK 

INTEGER* 2 

0168 

!  MONTH 

MONTH  OF  THE  YEAR 

INTEGER* 2 

0169 

!  NET 

NUMBER  OF  BT  POINTS 

INTEGER* 2 

r*  to 

i  NEWBT 

FLAG  FOR  INPUTTING  OF  NEW  BT 

INTEGER* 2 

L  /I 

l  NHIST 

FLAG  FOR  HISTORICAL  SSP  ENTRY 

INTEGER* 2 

RANGE 


Y  OR  N 


C-l7'3 


ENVIRN  14-Dec-1984  08  .*31:16 

14-Dec-1984  08:31:1E 

0172  1  NP  NUMBER  OF  BT  POINTS  INTEGER*?. 

O’P  !  NUM  NUMBER  OF  BT  POINTS  INTEGER*? 

>4  !  SUM  FACTOR  FOR  DEPTH  CALCULATIONS  REAL*4 

0175  l  ZB  DEPTH  IN  FEET  REAL*4 

0176  ! 

0177  !  ***  VARIABLES  NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMONS  *** 

0178 

0179  INTEGER* 2  I , IDD , IFIN , INPBDF , INSSP , IFRINT, IROC( 15 ) , ISTR , IYY 

0180  INTEGER* 2  J, JANS, K,MAPFLG, MONTH, NBT,NEWBT,NHIST,NP, NUM 

0181  REAL* 4  SUM, ZB 

0182  DATA  IROC  / ' N. ' , ' PA' , ' C . ' , ' NL ' , ' AN' , ' T. ' , ' ME ' , ' DS ' , 

0183  1  'EA' ,'IN' ,'DI' ,'AN' ,'N0' ,'RS' ,'EA'/ 

0184 

0185  i - PRELIMINARIES - 

0186  MAPFLG= .TRUE.  !  INITIALIZE  MAP  FLAG 

0187  CLOSE( UNIT=6 )  !  CLOSE  PRINT  UNIT 

0188  IF ( IPRINT . EQ . '  Y ' ) OPEN ( UNIT= 6 ,NAME= ' ENVIRN. LST; 1 ' ,DISP= ' PRINT ' , 

0189  1  STATUS =' UNKNOWN ' )  l  OPEN  PRINT  UNIT 

0190  IF( IPRINT. EQ. 'N' ) OPEN ( UN IT= 6 ,NAME= ' ENVIRN . LST; 1 ' , STATUS =' UNKNOWN ' ) 

0191  CALL  ICLR  !  CLEARS  SCREEN 

0192 

0193  READ ( 2 ' 1 )N, ( Z( I ) ,C(I) ,I=1,N) ,DLYR , i  READ  LAST  STORED  SSP  DATA 

0194  1  MGS, BDF,WS,CS,TMP, BIO, UMKZ,LAT, LONG, NOC,INDX,RCZ,NSN, 

0195  2  NMAREA , SYDATE , SYTIME , BTDATE , BTTIME , SNDATE , SNTIME , 

0196  3  SLNTY, ILYR,NNBT, (DD( I ) ,TT( I ) ,1=1 ,NNBT) , 

0197  4  NN,(ZZ(I) ,CC(I) ,1=1, NN) , INPBDF, ISVP, 

0198  5  INBT , ( DBT ( I ) , VBT ( I ) ,1=1, INBT ) 

0199  EL=DLYR  !  CHANGE  'EL'  TO  'DLYR' 

r^OO  MGSOP=MGS  !  CHANGE  'MGSOP'  TO  'MGS' 

}ll  ZB=6.  *BDF  l  ASSIGN  DEPTH  IN  FEET 

0202  CALL  ICLR  !  CLEAR  SCREEN 

0203  ISTR= ( NOC-1 ) *3+1  !  START  OF  IROC  ARRAY 

0204  IFIN=ISTR+2  l  FINISH  OF  IROC  ARRAY 

0205 

0206  WRITE( 5 , 145 ) BTDATE( 1 ) , BTDATE ( 2 ) , BTTIME ( 1 ) , BTTIME ( 2 ) , BTTIME ( 4 ) , 

0207  1  BTTIME ( 5) , BTDATE ( 4 ) , BTDATE ( 5 ) ,BTDATE( 6) , BTDATE ( 8) , BTDATE ( 9) , 

0208  2  ( IROC ( I ) , I=ISTR , IFIN) , INDX  !  DISPLAY  LAST  SSP  DATA 


0209 

0210 

0211 

0212 

0213 

0214 

0215 

0216 

0217 

0218 

0219  !  — 

0220 
0221 
0222 
0223 
0224 
0225 
0226 

0^27  282 

i8 


READ( 5 ,1050 )  JANS 

IF( JANS.NE. 'Y' )  GO  TO  340 

CALL  DATE (SYDATE) 

CALL  TIME (SYTIME) 

CALL  MAP ( MAFFLG) 

CALL  ICLR 
WRITE( 5,1475) 

REALM  5,1360)  INSSP 


CALL  ICLR 

NBT=0 

INBT=0 

CALL  KEYFCH( INSSP ,NBT, MAFFLG) 
ISVP=2 

INPBDF=INT ( BDF+0 . 5 ) 

IF ( INSSP . EQ . 2 )  GO  TO  320 
CALL  XBT(  INSSP, NBT,NHIST,NEWBT) 
IF(NEWBT.EQ.l)  THEN 


!  NEW  BT/SSP  DATA  QUERY 
!  NEW  BT/SSP  RESPONSE 
l  GET  SYSYEM  DATE 
l  GET  SYSTEM  TIME 
l  GET  MODULES  IN  TASK 
!  CLEAR  SCREEN 
!  ASK  FOR  TYPE  OF  SSP  ENTRY 
!  MANUAL  OR  HIST  SELECTION 

MANUAL - 

l  CLEAR  SCREEN 

!  INITIALIZE  #  OF  XBT  POINTS 
!  INITIALIZE  #  OF  XBT  POINTS 
l  GET  OPERATOR  INPUT  PAIRS 
!  SVP  CHOICE  2 
!  INPUT  BOTTOM  DEPTH 
!  INPUTTED  SSP  CHOICE  IS  2 
!  CORRECT  POSSIBLE  BT  ERRORS 
!  NEW  BT  NEEDED 


C-I9.V 


ENVIRN 


14-Dec-19B4  08:31:1£ 
14-Dec-1984  08:31ilf 


0229 
0-730 
Bl 
0232 
0233 
0234 
0235 
0236 
0237 
0238 
0239 
0240 
0241 
0242 
0243 
0244 
0245 
0246 
0247 
0248 
0249 
0250 
0251 
0252 
0253 
0254 
0255 
0256 
0  257 
>8 
0259 
0260 
0261 
0262 
0263 
0264 
0265 
0266 
0267 
0268 
0269 
0270 
0271 
0272 
0273 
0274 
0275 
0276 
0277 
0278 
0279 
0280 
0281 
0232 
0283 
0*784 
)5 


CALL  BT( INSSP ,NBT) 
GOTO  282 
END  IF 

IF ( NHIST . EQ . 1 )  THEN 


!  GET  OPERATOR  INPUT  AGAIN 
!  GO  BACK  TO  CALL  XBT 
!  END  IF  BLOCK 
!  SKIP  TO  HISTORICAL  PART 


!  -- 
320 


335 


350 


ISVP=1 

INBT=0 

DO  335  1=1, NS 
Z ( I ) =DS ( I ) 
C(I)=VS(I) 
CONTINUE 
N=NS 
END  IF 


ZB  =  6.*BDF 

CALL  INSERT ( N , Z , C , ZB , NUM ) 
N=NUM 


•HISTORICAL - 

!  SET  IS VP  TO  ONE 

!  SO  SVFGRF  WON'T  DISPLAY  LAST  XB: 
1  DO  FOR  NUMBER  OF  BTS 
I  DEPTH 
!  VELOCITY 
!  END  DO  LOOP 

!  NUMBER  OF  DEPTH/VELOCITY  PAIRS 
!  END  IF  BLOCK 

•CORRECTED  VALUES - 

!  ESTIMATED  BOTTOM  DEPTH 
!  INSERT  DEPTH  INTO  SSP 
!  SET  NUMBER  OF  BTS 


IF  C  NUM . GT .50)  THEN 
Z( 50) =ZB 

C(50)=C(48)+(ZB-Z< 
N=50 
END  IF 
SUM=0 . 

CALL  DUPDEP ( N , Z , C ) 
CALL  DUFVEL ( N , Z , C ) 

DO  350  1=2, N 

SUM=SUM+(Z(I)-Z(I- 
CONTINUE 
SUM=0.5*SUM/Z(N) 
BDF=BDF*SUM/4800. 
ZB=6 . *BDF 


!  >  50  BTS 
!  DEPTH  OF  50TH  BT 

48))/(Z(49)-Z(48) )*(C( 49) -C( 48) )  l  VELOCITY 
!  NUMBER  OF  BT 
l  END  IF  BLOCK 
!  SET  SUM  TO  ZERO 
!  CHECK  FOR  DUPLICATE  DEPTHS 
!  CHECK  FOR  DUPLICATE  VELOCITY 
1  DO  FOR  NUMBER  OF  BT 

1) )*(C(I)+C(I-1) )  !  SUM  IN  FT*FT/SEC 
I  END  DO  LOOP 
!  EVALUATED  SUM  IN  FT/ SEC 
!  CORRECTED  BOTTOM  (FATHOMS) 

!  CORRECTED  BOTTOM  DEPTH (FT) 


C(N)=C(N-1)+(C(N)-C(N-1) )*(ZB-Z(N-1) ) / ( Z(N) -Z(N-l) ) 
Z(N)=ZB  ! 

CS=C(1)  l 

CALL  VELTMP (2(1) , C ( 1 ) , TMF , SLNTY )  ! 

IF(TMP.LE. 1 . )  TMP=0 . 

CALL  LAYER (N,Z,C,DLYR) 


EL=DLYR 

CALL  NQCONV ( RCZ , ILYR ) 
CALL  DUPDEP ( N , Z , C ) 
CALL  DUFVEL ( N , Z , C ) 

340  WRITE( 6 , 2300 ) 

CALL  ICLR 

CALL  SVFGRF ( INPBDF ) 
CALL  ICLR 


!  VELOCITY 

CORRECTED  DEPTH 
SURFACE  VELOCITY 
GET  SURFACE  TEMPERATURE 
I  NO  NEGATIVE  TEMPS  ALLOWED 
!  LOCATE  LAYER  DEPTH 
l  LAYER  DEPTH 
!  FIND  CZ  RANGE 
!  CHECK  FOR  DUPLICATE  DEPTHS 
!  CHECK  FOR  DUPLICATE  VELOCITY 
!  'NEW  DATA  TO  BE  STORED' 

!  CLEAR  SCREEN 
!  GRAPHIC  DISPLAY  OF  SVP 
l  CLEAR  SCREEN 


WRITE ( 2'1)N,(Z(I),C(I) , 1=1 ,N) ,EL,MGSOP ,BDF,WS , 

1  CS , TMF , BIO ,UMKZ , LAT , LONG , NOC , INDX , RCZ , NSN , NMAREA , 

2  S YDATE , SYTIME , BTDATE , BTTIME , SNDATE , SNTIME , 

3  SLNTY, ILYR, NNBT, (DD( I) ,TT( I) ,I=1,NNBT) ,NN, 

4  (SZ(I) ,CC(I), 1=1, NN) , INPBDF, ISVF,  !  WRITE  NEW  DATA 

5  INBT , ( DBT ( I ) , VBT ( I ) ,1=1, INBT ) 

CLOSE (UNIT=6)  !  CLOSE  PRINT  UNIT  6 

RETURN  I  RETURN  TO  CALLING  ROUTINE 


<L-\OS 


ENVIRN 

0286 

02B7 

j - 

8 

0289 

0290 

0291 

0292 

145 

0293 

800 

0294 

850 

0295 

1050 

0296 

1360 

0297 

0298 

0299 

1475 

0300 

0301 

2800 

14-Dec-19B4 

14-Dec-19B4 


FORMAT  STATEMENTS - 

FORMAT ( 5X , '  LAST  BT  TAKEN  ON ' , 2X, 6A1 , ' Z  ',3A1,'  ',2A1, 

1  '  IN  ' ,  3A2 , '  AREA! ' ,12 

2  /  5X ,  '  IF  BT  DATA  IS  MORE  THAN  4  HOURS  OLD,  NEW  BT  NEEDED'/ 

3  / 5X , ' DO  YOU  WISH  TO  ENTER  NEW  BT/SSP  DATA?' 

4  /4X, ' ****ANSWER  YES  OR  NO**** ' ,T60 , '  ') 

FORMAT ( /4X, '****  ENTER  TRUE  WIND  SPEED  (XX  KTS )  ****', T60,' 
FORMAT (FI 0.0) 

FORMAT (Al) 

FORMAT (14) 

FORMAT ( 5X, ' ****SELECT  TYPE  OF  SSP  DESIRED****' 

1  / / / 8X , ' 1  =  MANUAL  BT' 

2  / BX r ' 2  =  HISTORICAL  SSP  FOR  AREA  AND  SEASON' ,T60 , ' 
FORMAT (1H1,T2 2, 'NEW  DATA  TO  BE  STORED:') 

END 


08:31:16 
08:31: If 


'  ) 


) 


COMMAND  QUALIFIERS 

FORTRAN  /CHECK=ALL/LIST/SHOW= ( INCLUDE , NOMAP )  CLAFLEUR3ENVIRN . F77 

/  CHECK  =  ( BOUNDS  ,  OVERFLOW ,  UNDERFLOW ) 

/ DEBUG = ( NOSYMBOLS ,TRACEBACK ) 

/ STANDARD- ( NOSYNTAX , NOSOURCE_FORM ) 

) SHOW= ( NOPREPROCESSOR ,  INCLUDE , NOMAP ) 

/F77  /NOG  FLOATING  /I4  /OPTIMIZE  /WARNINGS  /NOD_LINES  / NOCROSS_REFERENCE  /I 


COMPILATION  STATISTICS 


Run  Time : 
Elapsed  Time: 
Page  Faults: 
Dynamic  Memory: 


5.17  seconds 
7.19  seconds 
467 

135  pages 


c-n  i 


0001 
Q  0  0  2 
)003 
0004 
0005 
0006 
0007 
0008 
0009 
0010 
0011 
0012 
0013 
0014 
0015 
0016 
0017 
0018 
0019 
0020 
0021 
0022 
0023 
0024 
0025 
0026 
0027 
0028 
0,029 


INTEGER* 2  FUNCTION  FLOOR (REAL) 

PROLOGUE : 

MODULE  NAME:  FLOOR 

AUTHOR:  E.  PETR IDES  &  P.  FRAGEORGI A  OF  SYSCON,  INC 

RECODED:  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  1982  &  6/84  (FORTRAN  77) 

FUNCTION:  FUNCTION  FLOOR  DETERMINES  THE  MAXIMUM  INTEGER* 2 

THAT  IS  LESS  THAN  OR  EQUAL  TO  THE  REAL  VALUE  PASSED 
TO  THE  FUNCTION. 

INPUTS:  REAL  NUMBER  PASSED  TO  FIND  FLOOR  OF 
OUTPUTS:  MAXIMUM  INTEGER*2  <=  REAL  NUMBER  PASSED  IN 
MODULES  CALLED:  NONE 
CALLED  BY:  MAP 

VARBL  SIZE  PURPOSE  TYPE  RANGE 


I  TRUNCATED  REAL  VALUE  INTEGER* 2 

REAL  A  REAL  VALUE  REAL *4 

INTEGER*2  I 
REAL *4  REAL 

I = INT ( REAL )  !  TRUNCATE  REAL  VALUE 

FLOOR= I + ( REAL . LT . 0 . )  !  IF  REAL  NEG ,  OFFSET 

IF  ( FLOAT 1(1). EQ . REAL )  FLOOR3 I  !  NUMBERS  EQUAL,  NO  OFFSET 

RETURN  !  RETURN  TO  CALLING  ROUTINE 

END  !  END  SUBROUTINE 


0001  INTEGER* 2  FUNCTION  FNP(I) 

0002 

J003  !  PROLOGUE: 

0004  !  MODULE  NAME:  FNP 

0005  !  AUTHOR:  E.  PETR IDES  &  P.  FRAGEORGI A  OF  SYSCON,  INC 

0006  !  RECODED:  W.  WACHTER,  CODE  3333,  NUSC/NLL 

0007  !  DATE:  1982  &  6/84  (FORTRAN  77) 

0008  !  FUNCTION:  FUNCTION  FIND  POINT  IS  DESIGNED  TO  GET  THE 

0009  !  LATITUDE/LONGITUDE  VALUE  OF  POINT  I . 

0010  !  INPUTS:  PARAMETER  I  PASSED  IN 

0011  !  OUTPUTS:  LATITUDE/LONGITUDE  VALUE  OF  POINT  I. 

0012  !  MODULES  CALLED:  NONE 

0013  !  CALLED  BY:  DNUT ,  GRAPH 

0014  ! 

0015  INCLUDE  'MAP. PAR' 

0016  1  PARAMETER  STOLEN=3800 

0017  1  PARAMETER  SEGLEN=60 ,  POLLEN=40 

0018  1  PARAMETER  WRKLEN=1000,  NDXLEN=300 

0019  1  PARAMETER  MAXDTY  =  3 

0020  1  PARAMETER  TOL=3 

0021  1  PARAMETER  DEG=57 . 2957795 

0022  1  PARAMETER  RAD= . 017453293 

0023  1  PARAMETER  PI=3 . 14159265 

0024  1  PARAMETER  ERAD=3440.3 

0025  1  PARAMETER  S251=63001 

0026  1  PARAMETER  TW015=32768 

0027  1 

0028  1  !  INTEGER*2  MAXDTY , NDXLEN , POLLEN , SEGLEN, STOLEN , TOL , WRKLEN 

1029  1  !  INTEGER*4  S251,TW015 

/030  1  !  REAL *4  DEG ,  ERAD ,  PI ,  RAD 

0031  INCLUDE  'CS.INC' 

0032  1  !  - CS - 

0033  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0034  1  ! -  -  -  - 

0035  1  !  S  -1,3800  POLYGON  AND  SEGMENT  STORAGE  ARRAY  REAL *4 

0036  1  !  STOLEN  STORAGE  ARRAY  LENGTH  (FOR  SEGS  &  POLYS)  PARM 

0037  1  ! 

0038  1  REAL *4  S(-l:STOLEN) 

0039  1 

0040  1  COMMON  /CS/  S 

0041  1  ! - CS-END - 

0042  1 

0043  ! 

0044  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0045  ! -  -  -  - 

0046  !  I  INDEX  FOR  THE  POINT  VALUE  INTEGER* 2 

0047  !  J  ABSOLUTE  VALUE  OF  I  INTEGER* 2 

0048  ! 

0049  !  ***  VARIABLES  NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMONS  *** 

0050 

0051  INTEGER*2  I,J 

0052 

0053  FNP=0  !  INITIALIZE  FIND  POINT 

0054  IF  (I.GT.12)  FNP=I+4  I  INDEX  OF  1ST  END  PT  OF  SEGMENT 

0055  J-ABS(I)  >  MUST  BE  POSITIVE  VALUE 

'*056  IF  (I.LT.-12)  FNP=I  IFIX(S(  J)  )-I  +  3  !  SET  TO  LAST  PT  OF  SEGMENT 

057  IF  (FNP.NE.0)  GO  TO  999  !  RETURN  TO  CALLING  PROGRAM 

0058  WRITE (5, 102)  !  ERROR  MESSAGE 

0059  999  RETURN  !  RETURN  TO  CALLING  ROUTINE 


c-n.i 


0060 

y>61  ! - FORMAT  STATEMENT - 

J 062  102  FORMAT (X, 'PROGRAM  ERROR,  ATTEMPT  TO  USE  FNP  ON  BORDER') 

0063  END 


COMMAND  QUALIFIERS 

FORTRAN  /CHECK=ALL/LIST/SHOW=( INCLUDE, NOMAP)  [ LAFLEUR] FNP . F77 

/CHECK= ( BOUNDS , OVERFLOW , UNDERFLOW ) 

/DEBUG® ( NOSYMBOLS , TRACEBACK ) 

/STANDARD® ( NOSYNTAX , NOSOURCE_FORM ) 

/SHOW® ( NOPREPROCESSOR , I NCLUDE , NOMAP ) 

/F77  /NOG  FLOATING  /I4  /OPTIMIZE  /WARNINGS  /NOD  LINES  /NOCROSS  REFERENCE 


COMPILATION  STATISTICS 


Run  Time: 
Elapsed  Time: 
Page  Faults: 
Dynamic  Memory: 


0.87  seconds 
1.73  seconds 
364 

123  pages 


C-H.t 


14-Dec-19B4  08:32:1 
14-Dec-1984  08:32:1 


0001 

P0j32 

0004 

0005 

0006 

0007 

0008 

0009 

0010 

0011 

0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 

0021 

0022 

0023 

0024 

0025 

0026 

0027 

0028 


SUBROUTINE  FORCST ( IPRINT) 

PROLOGUE: 

MODULE  NAME:  FORCST 

AUTHOR:  G.  BROWN  &  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  1974  &  11/83  (FORTRAN  77) 

FUNCTION:  SUBROUTINE  FORCST  OBTAINS  ENVIRONMENTAL  PARAMETERS 
FROM  HISTORICAL  DATA  FOR  THE  AREA  AND  MONTH. 
INPUTS:  INPUTTED  PARAMETERS.  VARIABLES  IN  COMMONS. 

OUTPUTS:  FORECASTING  DATA  FILES. 

MODULES  CALLED:  DUPDEP , DUPVEL , I CLR , INSERT, KEYPCH, LAYER, MAP, 

NOCONV , SVPGRF , VELTMP ,XBT 

CALLED  BY:  SIMAS 


ALGORITHMS  USED: 

CORRECTION  FACTOR- . 5*SUMMATI0N  FROM  2  TO  N  OF  ( Z( I ) -Z ( 1-1 ) *C( 1-1 ) 

DIVIDED  BY  Z(N)  *  4800FT/SEC 

TRUE  DEPTH  =  (ESTIMATED  BOTTOM  DEPTH , Z ( N ) )  *  CORRECTION  FACTOR 

(C(N)-C(N-l) )*(ZB-Z(N-1) ) 

SOUND  VELOCITY  FOR  TRUE  DEPTH  =  C(N-l)  +  - 

Z(N)  -  Z(N-l) 

WHERE  ZB  IS  THE  TRUE  DEPTH 


0  029 
>0 
0031 
0  032 
0033 
0034 
0035 
0036 
0037 
0038 
0039 
0040 


1 

1 

1 

1 

1 

1 

1 

1 

1 


-DHST- 


0049 

0050 

0051 

0052 

0053 

0054 

0055 

p15 


l 

l 

l 

1 

l 

l 

l 

1 


INCLUDE  ' DHST . INC ' 

VARBL  SIZE  PURPOSE  TYPE 

SCHNLD  SOUND  CHANNEL  LAYER  DEPTH  REAL* 4 

REAL* 4  SCHNLD 

COMMON  /DHST/  SCHNLD 
INCLUDE  ' DTV. INC ' 


RANGE 


-DHST  END- 
- DTV - 


0041 

1 

i 

VARBL 

SIZE 

PURPOSE 

TYPE 

0042 

1 

i 

— 

— 

0043 

1 

| 

D 

(25) 

DEPTH 

REAL* 4 

0044 

1 

1 

DD 

(25) 

DEPTH 

REAL*4 

0045 

1 

i 

NNBT 

NUMBER  OF  BATHETHERMAL 

INTEGER’ 

0  046 

1 

i 

T 

(25) 

TEMPERATURE 

REAL* 4 

0047 

1 

i 

TT 

(25) 

TEMPERATURE 

REAL* 4 

0048 

1 

i 

VEL 

(25) 

VELOCITY 

REAL*4 

RANGE 


INTEGER* 2  NNBT 
REAL*4  D,DD,T,TT,VEL 

COMMON  /DTV/  D( 25 ) ,T( 25 ) , VEL( 25 ) ,DD( 25 ) ,TT( 25 ) ,NNBT 

i - END  DTV - 

INCLUDE  ' ENVN . INC ' 

i - ENVN - 

!  VARBL  SIZE  PURPOSE  TYPE  RANGE 


C-20.  I 


F’ORCST  14-Dec-1984  08  s  32.*  IS 

14-Dec-1984  08s32sl] 

0058  1  ! -  -  -  - 

0059  1  !  BIO  (2)  BIOLOGICAL  BACK  SCATTERING  REALM  -57.  &  -47. 

BO  1  !  DLYR  LAYER  DEPTH  REALM 

0061  1  !  MGS  MGS  PROVINCE  INTEGER* 2  • 

0062  1 

0063  1  REAL* 4  BIO ,DLYR 

0064  1  INTEGER* 2  MGS 

0065  1  DATA  BIO/ -57. ,-47. / 

0066  1 

0067  1  COMMON  /ENVN/  BIO { 2 ) ,DLYR ,MGS 

0068  1 

0069  1  ! - END  ENVN - 

0070  INCLUDE  ' GRF . INC ' 

0071  1  ! - GRF - 

0072  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0073  1  ! -  -  -  - 

0074  1  !  DBT  (25)  DEPTH  OF  DEPTH/VEL  PAIR  REAL* 4 

0075  1  1  IANS  PREDICTION  TYPE  INTEGER* 2  -2  TO  +2 

0076  1  !  ILYR  INDEX  FOR  LAYER  DEPTH  INTEGER* 2 

0077  1  !  INBT  OPERATOR  ENTERED  #  OF  BT  POINTS  INTEGER* 2 

0078  1  !  ISVP  LATEST  OR  HISTORICAL  BT  FLAG  INTEGER* 2  1  OR  2 

0079  1  1  12000  SVP  INDEX  FOR  2000  FT  DEPTH  INTEGER* 2 

0080  1  1  VBT  (25)  VELOCITY  FOR  DEPTH  PAIR  REAL*4  REAL*4 

0081  1 

0  082  1  REAL*4  DBT,  VBT 

0083  1  INTEGER* 2  IANS , ILYR , INBT , ISVP , 12000 

0084  1 

0085  1  COMMON  /GRF/  IANS , ISVP , ILYR, 12000 , INBT ,DBT( 25 ) ,VBT( 25 ) 

r^Q6  1 

hi  1  ! - END  GRF - 

0088  INCLUDE  'LOC.INC' 

0089  1  ! - LOC - 

0090  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0091  1  ! -  -  -  - 

0092  1  !  INDX  SSP  INDEX  INTEGER* 2 

0093  1  i  LAT  (4)  LATITUDE  INTEGER* 2 

0094  1  !  LONG  (4)  LONGITUDE  INTEGER* 2 

0095  1  !  NMAREA  (20)  AREA  OCEAN  NAME  BYTE 

0096  1  1  NOC  NUMBER  OF  OCEAN  INTEGER* 2 

0097  1  I  RCZ  RANGE  TO  CONVERG.  ZONE  REAL* 4 

0098  1 

0099  1  REAL* 4  RCZ 

0100  1  INTEGER* 2  INDX, LAT, LONG, NOC 

0101  1  BYTE  NMAREA ( 20) 

0102  1 

0103  1  COMMON  /LOC/  LAT ( 4 ), LONG ( 4 ), NOC , INDX , RCZ , NMAREA 

0104  1 

0105  1  ! - END  LOC - 

0106  INCLUDE  'SVP. INC' 

0107  1  1 - SVP - 

0108  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0109  1  !  - -  -  -  - 

0110  1  !  BDF  BOTTOM  DEPTH  IN  FATHOMS  REAL*4 

0111  1  I  BIOP  BIOLOGICAL  BACK  SCATTERING  COEF  REAL*4 

0112  1  !  BTDATE  (9)  DATE  OF  LAST  BT  INPUT  BYTE 

O'1  13  1  !  BTTIME  (3)  TIME  OF  LAST  BT  INPUT  BYTE 

M  1  !  C  (50)  VELOCITY  (PAIRED  WITH  Z  FOR  SVP)  REAL*4 


C-2-V.z. 


FORCST 


0115  1 

0116  1 
\7  1 

0118  1 
0119  1 

0120  1 
0121  1 
0122  1 
0123  1 

0124  1 

0125  1 

0126  1 
0127  1 

0128  1 
0129  1 

0130  1 

0131  1 

0132  1 

0133  1 

0134  1 

0135  1 

0136  1 

0137  1 

0138  1 

0139  1 

0140  1 

0141  1 

0142  1 

O1 43  1 

>4  1 

0145  1 

0146  1 

0147  1 

0148 
0149  1 

0150  1 

0151  1 

0152  1 

0153  1 

0154  1 

0155  1 

0156  1 

0157  1 

0158  1 

0159  1 

0160  1 
0161  1 
0162  1 
0163  1 

0164  1 

0165 
0166 
0167 
0168 
0169 
0170 
«  )1 


14-Dec-19S4  08s32!l 
14-Dec-19B4  03s32:l 


cc 

(50) 

VELOCITY  (PAIRED  WITH  ZZ  FOR  SVP)REAL*4 

CS 

SOUND  VELOCITY  AT  SURFACE 

REAL* 4 

DEG 

TEMPERATURE  (DEG) 

REAL*4 

57.2957795 

EL 

LAYER  DEPTH 

DATA 

F 

FREQUENCY 

REAL* 4 

GRDS 

GRIDS 

REAL*4 

0.0164 

ITO 

MINIMAL  2 -WAY  TRAVEL  TIME 

INTEGER* 2 

MGS  OP 

MGS  PROVINCE  NUMBER 

INTEGER* 2 

N 

#  OF  DEPTH /VELOCITY  PAIRS 

INTEGER* 2 

NN 

#  OF  DEPTH /VELOCITY  PAIRS 

INTEGER* 2 

PI 

MATHEMATICAL  CONSTANT  PI 

REAL*4 

3.1415927 

SNDATE 

(9) 

DATE  SYS  PARMS  LAST  UPDATED 

BYTE 

SNTIME 

(8) 

TIME  SYS  PARMS  LAST  UFDTAED 

BYTE 

SYDATE 

(9) 

CURRENT  DATE  READ  FROM  SYSTEM 

BYTE 

SYTIME 

(8) 

CURRENT  TIME  READ  FROM  SYSTEM 

BYTE 

TMP 

TEMPERATURE 

REAL*4 

UMKZ 

BOTTOM  BACK  SCATTERING  COEF. 

REAL*4 

o 

4 

03 

1 

W  S 

WIND  SPEED 

REAL*4 

z 

(50) 

DEPTH  OF  POINT  OF  SOUND  SPEED 

REAL* 4 

zz 

(50) 

DEPTH  OF  POINT  OF  SOUND  SPEED 

REAL*4 

INTEGER* 2  ITO ,MGSOP ,N ,NN 

REAL* 4  BDF,BIOF,C( 50) ,CC(50) ,  CS , DEG , EL , F , GRDS 

REAL* 4  PI ,TMP ,UMKZ ,WS , Z ( 50 ) ,  ZZ( 50 ) 

BYTE  SYDATE ( 9 ) ,SYTIME(8) , BTDATE ( 9 ) ,BTTIME( B) 

BYTE  SNDATE ( 9 )  , SNTIME ( 8 ) 

DATA  PI , DEG, GRDS/ 3 . 1415927 , 57 . 2957795 , 0 . 0164/ 

DATA  UMKZ/ -28./ 


COMMON  /SVF/  F,N ,Z ,C ,EL ,MGSOP, BDF ,WS ,CS ,TMP , BIOP , 

1  UMKZ ,PI ,DEG ,GRDS , ITO ,ZZ ,CC,NN, 

2  SYDATE, SYTIME, BTDATE, BTTIME, SNDATE, SNTIME 

- SVF-END - 

INCLUDE  'SVP1.INC' 

- SVPl - 

VARBL  SIZE  PURPOSE  TYPE  RANGE 


BUFFER  (224) 

DS  (30) 

J20 

NS 

NSN 

SLNTY 

VS  (30) 


HISTORICAL  DATA  FILE  BUFFER 
HISTORICAL  DEPTH 
#  OF  DEEP  OCEAN  DEPTH /VEL  PAIRS 
TOTAL  #  OF  PAIRS  IN  HISTORICAL 
MONTH  NUMBER  (1=JAN. ,ETC) 
SALINITY 

HISTORICAL  VELOCITY 


REAL* 4 
REAL*  4 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
REAL *4 
REAL*4 


1  TO  12 


REAL* 4  BUFFER , DS , SLNTY , VS 

INTEGER*2  J20,NSN,NS 

COMMON  /SVPl/  J20,BUFFER(224) , NSN, SLNTY, DS(30) ,VS(30) , NS 

- END  SVP1 - 


VARBL  SIZE 

PURPOSE 

TYPE 

I 

COUNTER 

INTEGER* 2 

INPBDF 

INPUTTED  BOTTOM  DEPTH 

INTEGER* 2 

INSSP 

DATA  INPUT  SELECTION 

INTEGER* 2 

IPRINT 

PRINT  FLAG 

INTEGER*! 

c-io.  3 


FORCST 


0172 

0173 

0175 
0176 
0177 
0178 
0179 
0180 
0181 
0182 
0183 
0184 
0185 
0186 
0187 
0188 
0189 
0190 
0191 
0192 
0193 
0194 
0195 
0196 
0197 
0198 
0199 
0  300 

0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 

0211 

0212 

0213 

0214 

0215 

0216 

0217 

0218 

0219 

0220 

0221 

0222 

0223 

0224 

0225 

0226 

0727 

)3 


14-Dec-1984  08s 32:1 
14-Dec-1984  08:32:1 


J 

COUNTER 

INTEGER* 2 

K 

COUNTER 

INTEGER* 2 

MAPFLG 

FLAG  FOR  MAP  TASK 

INTEGER* 2 

NBT 

NUMBER  OF  BATHETHERMAL 

INTEGER* 2 

NEWBT 

FLAG  FOR  NEW  BT  DATA 

INTEGER* 2 

NHIST 

FLAG  FOR  HISTORICAL  BT  DATA  INTEGER* 2 

NP 

NUMBER  OF  BT  +  1 

INTEGER* 2 

NUM 

#  OF  POINTS  TO  INSERT  IN 

SVPINTEGER*2 

SUM 

FACTOR  IN  DEPTH  EQUATION 

INTEGER* 2 

SB 

BOTTOM  DEPTH  IN  FEET 

REAL* 4 

***  VARIABLES 

NOT  LISTED  HERE  ARE  IN  COMMON  ENVN ,GRF 

,  LOC , SVP , SVP1  ** 


INTEGER* 2  MAPFLG 

INTEGER* 2  I ,INPBDF, INSSP, IPRINT,J,K 
INTEGER* 2  NET , NEWBT , NHI ST , NP , NUM 
REAL*4  SUM, ZB 


- PRELIMINARIES - 

MAPFLG = . TRUE .  !  INITIALIZE  MAP  FLAG 

CALL  ICLR  i  CLEAR  SCREEN 

CLOSE( UNIT=6 )  i  CLOSE  UNIT  6 

IF( IPRINT.EQ . 'Y' ) OPEN ( UNIT=6 , NAME= ' FORCST . LST } 1 ' ,DISP= ' PRINT' , 

1  STATUS  = ' UNKNOWN ' )  I  PRINT  OPTION 

IF( IPRINT.EQ. 'N' ) OPEN ( UNIT=6 ,NAME= ' FORCST. LST; 1 ' , STATUS =' UNKNOWN ' ) 
CALL  ICLR  !  CLEAR  SCREEN 

I  READ  FORECASTING  DATA  FILE 
READ (  2 ' 1 )  N ,  ( Z  ( I ) ,C(I) ,I=1,N) ,  DL YR ,  MGS  ,  BDF ,  WS  , 

1  CS , TMP , BIO , UMKZ , LAT , LONG , NOC , INDX ,RCZ , NSN ,NMAREA , 

2  SYDATE , SYTIME , BTDATE , BTTIME , SNDATE, SNTIME, 

3  SLNTY , ILYR , NNBT , ( DD ( I ) ,TT(I) ,I=1,NNBT) , 

4  NN , ( ZZ ( I ) , CC ( I ) ,1=1, NN ) ,INFBDF,ISVP, 

5  INBT, ( DBT( I ) ,VBT( I ) , 1=1 , INBT) 


EL=DLYR 

MGSOF=MGS 

100  WRITE( 5 , 1400 ) 

READ( 5,1360)  INSSP 
IF(INSSF.EQ.l)  GOTO  9999 
IF( INSSP . LT. 1 . OR . INSSP . GT 


!  CHANGE  EL  TO  DLYR  THRU  SIMAS 
!  CHANGE  MGSOP  TO  MGS  THRU  SIMAS 
I  SELECT  DATA  INPUT  DESIRED 
•  READ  SELECTION 
!  USE  EXISTING  DATA  FILE 
5)  GOTO  100  !  INVALID,  LOOP  BACK 


282 


IF ( INSSP . EQ . 2 ) 

CALL  MAP (MAPFLG) 
NBT=0 
INBT=0 


SELECT  SVP  &  SET  MI SC.  PARMS--- 
AUTOMATED  HISTORY  DATA  ENTRY 
INITIATE  THE  MAP  TASK 
INITIALIZE  #  OF  BT 
INITIALIZE  INPUTTED  #  OF  BT 


CALL  KEYPCH( INSSP, NBT, MAPFLG)  1  OPERATOR  INPUT  SPECIFIC  PROFILE 


IF( INSSP . EQ . 4 )  ISVP=2  ! 
IF ( INSSP . EQ . 5 )  ISVP=5  ! 
INPBDF= INT ( BDF+O . 5 )  I 
IF ( INSSP . EQ . 5 )  GOTO  590  ! 
CALL  ICLR  ! 


SET  FLAG  FOR  LATEST  XBT  LABEL 
KEYPUNCH  OPTION 
INPUTTED  BOTTOM  DEPTH 
KEYPUNCH  ENTIRE  SSP  &  DATA  CHOICE 
CLEAR  SCREEN 

GOTO  333  l  CHOICE  2  AND  3 


IF ( INSSP . EQ . 2 . OR. INSSP . EQ . 3 ) 

CALL  XBT( INSSP, NBT, NHIST, NEWBT)  !  XBT  ERROR  CORRECTING 
IF ( NEWBT . EQ . 1 )  THEN  l  IF  TRUE,  ENTER  NEW  BT 

CALL  BT( INSSP, NBT)  !  ENTER  NEW  XBT 

GOTO  282  !  CHECK  NEW  XBT 


c:-2.o.  V 


FORCST 


14-Dec-1984 

14-Dec-1984 


08:32; 17 
08:32:13 


0229 

0230 


END  IF 


!  END  IF  BLOCK 


*1 

i - 

- HISTORICAL  SSP - 

0232 

IF ( NHIST . EQ . 1 )  THEN 

i 

IF  TRUE,  USE  HIST  ONLY 

t 

0233 

333 

ISVP=1 

i 

SET  FLAG  FOR  HISTORICAL  LABEL 

0234 

INBT=0 

i 

SO  SVPGRF  WON'T  DISPLAY  LAST  XBT 

0235 

DO  335  I  =  1 ,NS 

i 

DO  FOR  NUMBER  OF  BT 

0236 

Z(I)  =  DS ( I ) 

i 

HISTORICAL  DEPTH 

0237 

C(I)  =  VS(I> 

i 

HISTORICAL  VELOCITY 

0238 

335 

CONTTNUE 

i 

END  DO  LOOP 

0239 

N=NS 

i 

NUMBER  OF  DEPTH /VELOCITY  PAIRS 

0240 

END  IF 

i 

END  IF  BLOCK 

0241 

0242 

i - 

- INSERT  ESTIMATED  BOTTOM  DEPTH - 

ZB=6 . *BDF  l 

CALL  INSERT ( N ,  Z  ,  C  , ZB , NUM )  ! 

N=NUM  ! 

IF(NUM.GT. 50 )  THEN  < 

Z ( 50 ) =ZB  I 

C(50)=C(48)+( ZB-Z ( 48 )  )  / 
NUM=50 
END  IF 
SUM=0 . 

CALL  DUFDEP ( N ,  Z ,  C ) 

CALL  DUFVEL ( N ,  Z ,  C ) 

DO  350  1=2, N 

SUM=SUM+ ( Z ( I ) -Z ( 1-1 ) )*< 

350  CONTINUE 

SUM=0.5*SUM/Z(N) 
BDF=BDF*SUM/4800. 

ZB=6 . *BDF 


BOTTOM 
INSERT 
SET  N 
IF  >  50 
DEPTH 


DEPTH  IN  FEET 

DEPTH /VEL  POINT  INTO  SVP 

BT  POINTS 


(Z(49)-Z(48) )*<C(49)-C(48) )  !  DEPTH 


50 


MAX  NUMBER  IS 
END  IF  BLOCK 
INITIALIZE  SUM 
CHECK  FOR  DUPLICATE  DEPTHS 
CHECK  FOR  DUPLICATE  VELOCITY 
CORRECTIONS  FOR  TRUE  DEPTH 
C( I) +C( 1-1 ) )  !  SUM  IN  FT**2/SEC 

!  END  DO  LOOP 
!  SUM  IN  FT /SEC 
1  CORRECTED  DEPTH  IN  FATHOMS 
!  CORRECTED  DEPTH  IN  FEET 


590 


9999 


-  CORRECTED  VEL  &  DEPTH  ENTERED  IN  SSP 

C ( N ) =C(N-1 ) +( C(N) -C (N-l ) ) * ( ZB-Z ( N-l ) ) / ( Z( N) -Z ( N-l ) )  1  VELOCITY 
Z(N) =ZB  !  DEPTH 

CONTINUE  !  NEEDED  FOR  GOTO  STATEMENT 

CALL  VELTMP(Z(1) ,C( 1) ,TMF,SLNTY) !  OBTAIN  TEMP  AT  SURFACE 


IF(TMF.LE. 1 . )TMF=0 . 
CS=C(1) 

CALL  LAYER ( N ,  Z ,  C , DL YR ) 
EL=DLYR 

CALL  NQCQNV ( RCZ , ILYR ) 
CALL  DUPDEP ( N ,  Z  ,  C ) 
CALL  DUPVEL ( N , Z  ,C ) 
CALL  ICLR 

CALL  SVPGRF ( INPBDF ) 
CALL  ICLR 
WRITE ( 2 ' 1 ) 


l  MINIMUM  TEMPERATURE 
!  SOUND  VELOCITY  AT  SURFACE 
l  LOCATE  LAYER  DEPTH  IN  SVP 
‘  CHANGE  EL  TO  DLYR  IN  SIMAS 
i  FIND  RANGE  TO  CONVERG  ZONE 
!  CHECK  FOR  DUPLICATE  DEPTHS 
S  CHECK  FOR  DUPLICATE  VELOCITY 
i  CLEAR  SCREEN 
!  PRODUCE  GRAPH  OF  SVP 
!  CLEAR  SCREEN 

!  WRITE  FORECASTING  DATA  FILE 


1 

1 

2 

3 

4 

5 


N, (Z(I) ,C(I) ,I=1,N) , DLYR, MGS, BDF,WS, 

CS , TMP , BIO , UMKZ , LAT , LONG , NOC , INDX , RCZ , NSN , NMAREA , 
SYDATE , SYTIME , BTDATE , BTTIME , SNDATE , SNTIME , 

SLNTY , ILYR , NNBT , ( DD ( I ) ,TT(I) ,I=1,NNBT) , 

NN , ( ZZ ( I ) ,CC(I) ,1=1, NN ) , INPBDF, ISVP, 

INBT, (DBT( I) , VBT ( I ) ,1=1, INBT ) 

CL0SE(UNIT=6)  !  CLOSE  FILE  6 

RETURN  !  RETURN  TO  CALLING  ROUTINE 


c~a.o..r 


FORCST 


14-Dec-1984  08:32:1: 
14-Dec-19S4  08:32:13 


0286 

02B7 

)3 

0289 

0290 

0291 

0292 

0293 

0294 

0295 


I - FORMAT  STATEMENTS - 

1360  FORMAT ( 12) 

1400  FORMAT ( '  SELECT  INPUT  DESIRED:' 

1  ///,X,'l  =  USE  EXISTING  FILE  DATA', 

2  / / ,X, ' 2  =  USE  AUTOMATED  HISTORICAL  DATA  ENTRY  SELECTION', 

3  // ,X, ' 3  =  USE  MANUAL  HISTORICAL  DATA  ENTRY  SELECTION', 

4  / / ,X, ' 4  =  USE  MANUAL  BT/SSP  ENTRY  MERGED  W/  HISTORICAL', 

5  / / ,X, ' 5  =  KEYPUNCH  ENTIRE  SSP  AND  DATA' , 

6  / / / 1H$ , '  ****  ENTER  YOUR  CHOICE  *****', T60,'  ') 

END 


COMMAND  QUALIFIERS 

FORTRAN  / CHECK = ALL/ LIST/ SHOW= ( INCLUDE , NOMAP )  CLAFLEUR3F0RCST . F77 

/ CHECK  = ( BOUNDS , OVERFLOW, UNDERFLOW) 

/DEBUG= ( NOSYMBOLS ,TRACEBACK ) 

/ STANDARD = ( NOSYNTAX ,NOSOURCE_FORM) 

/ SHOW= ( NOPREPROCESSOR , INCLUDE , NOMAP ) 

/F77  /NOG  FLOATING  /I4  /OPTIMIZE  /WARNINGS  /NOD  LINES  /NOCROSS  REFERENCE  /l 


COMPILATION  STATISTICS 

4.68  seconds 
6.20  seconds 
452 

180  pages 


)tun  Time: 
Elapsed  Time: 
Page  Faults: 
Dynamic  Memory: 


02.0,  6 


0001 
0002 
>003 
0004 
0005 
0006 
0007 
0008 
0009 
0010 
0011 
0012 
0013 
0014 
0015 
0016 
0017 
0018 
0019 
0020 
0021 
0022 
0023 
0024 
0025 
0026 
0027 
0028 
0029 
)0  3  0 
0031 
0032 
0033 
0034 
0035 
0036 
0037 
0038 
0039 
0040 
0041 
0042 
0043 
0044 
0045 
0046 
0047 
0048 
0049 
0050 
0051 
0052 
0053 
0054 
0055 
0056 
10  57 
0058 
0059 


SUBROUTINE  FSETUP ( RECNDX , R) 

PROLOGUE: 

MODULE  NAME:  FSETUP 

AUTHOR:  E.  PETRI DES  &  P.  FRAGEORGI A  OF  SYSCON,  INC 
RECODED:  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  1982  &  6/84  (FORTRAN  77) 

FUNCTION:  THIS  SUBROUTINE  IS  DESIGNED  TO  READ  INFORMATION  FROM  THE 

FILE  "MAP" (OAC) "A" ,  CHECK  THE  LATITUDE  &  LONGITUDE  RANGES, 
AND  READ  IN  THE  PROPER  AMOUNT  OF  POINTER  FOR  THE  FILE 
"MAP " ( OAC )  "  B  "  . 

INPUTS:  DATA  FROM  FILES  READ  IN 
OUTPUTS:  MESSAGES  TO  OPERATOR 
MODULES  CALLED:  OPNFIL 
CALLED  BY:  MAP 


INCLUDE  'MAP. PAR' 

PARAMETER  STOLEN=3800 
PARAMETER  SEGLEN=60 ,  POLLEN=40 
PARAMETER  WRKLEN=1000,  NDXLEN=300 
PARAMETER  MAXDTY=  3 
PARAMETER  TOL=3 
PARAMETER  DEG=57 . 2957795 
PARAMETER  RAD= . 017453293 
PARAMETER  PI=3 . 14159265 
PARAMETER  ERAD=3440.3 
PARAMETER  S251=63001 
PARAMETER  TW015=32768 


I NTEGER*  2  MAXDTY , NDXLEN , POLLEN , SEGLEN , STOLEN , TOL , WRKLEN 
INTEGER* 4  S251,TW015 
REAL *4  DEG , ERAD , P I , RAD 

INCLUDE  * CFILE . INC ' 

- CFILE. INC - 

VARBL  SIZE  PURPOSE  TYPE  RANGE 


FNAME  (21) 
OPEN 


MAP  FILE  NAME 
OPEN  FLAG 


CHAR 

LOGICAL*!  .FALSE. 


LOG I CAL* 1  OPEN 

CHARACTER*!  FNAME (21) 


COMMON  /CFILE/  OPEN, FNAME 
- END  CFILE. INC - 


INCLUDE  'CL. INC' 


VARBL  SIZE 


-CL. INC- 


PURPOSE 


LATMAX  MAXIMUM  LATIITUDE 
L ATM I N  MINIMUM  LATIITUDE 
LNGMAX  MAXIMUM  LONGITUDE 
LNGMIN  MINIMUM  LONGITUDE 

I NTEGER* 2  L ATM IN, LATMAX , LNGMIN, LNGMAX 


TYPE  RANGE 

INTEGER*2 
I NTEGER* 2 
I NTEGER* 2 
I NTEGER* 2 


COMMON  /CL/  LATMIN, LATMAX, LNGMIN, LNGMAX 
- END  CL. INC - 


C-S.U 


0060 

0061 

1)062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 

0081 

0082 

0083 

0084 

0085 

0086 

0087 

0088 

)089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 

0101 

0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 

0111 

0112 

0113 

0114 

0115 

)116 

0117 

0118 


VARBL  SIZE  PURPOSE 


TYPE  RANGE 


A 

B 

I 

J 

K 

L  (4) 

R 

REC 

RECBUF  (64) 
RECNDX  (300) 
RERR 
RTEST 
W 


. TRUE .  BYTE 

.FALSE.  BYTE 

COUNTER  INTEGER* 2 

NUMBER  OF  INDEXES  INTEGER* 2 

COUNTER  INTEGER* 2 

LAT; LNG  MINIMUM; MAXIMUM  ARRAY  INTEGER*2 
ERROR  WITH  FILE  "MAP" (OAC) "A"  BYTE 

NUMBER  OF  RECORDS  COUNTER  INTEGER*2 

RECORD  BUFFER  INTEGER*2 

POINTERS  INTO  "MAP" (OAC) "B"  INTEGER*2 
NUMBER  OF  ERRORS  IN  INDEX  FILE  INTEGER* 2 
TEST  LAT; LNG  VALIDITY  BYTE 

NUMBER  OF  ITEMS  READ  FROM  FILE  INTEGER* 2 


TRUE 

FALSE 


***  VARIABLES  NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMONS  *** 


INTEGER* 2  I , J , K , REC , RECMAX , RERR , W 
INTEGER *2  RECNDX ( NDXLEN) ,L(4) , RECBUF (64) 
BYTE  RTEST, R, A, B 

EQUIVALENCE  ( LATMIN, L ( 1 ) ) 

DATA  A , B/ . TRUE . , . FALSE . / 


R=. FALSE. 

CALL  OPNFIL( A, R) 

IF  (R)  GO  TO  999 

READ  (4*1, ERR=150 )  (L(I),I=1,4) 


DATA  BASE  ERROR  FLAG 
OPEN  MAP  INDEX  FILE 
ERROR  IN  OPENING,  RETURN 
READ  MIN/MAX  LAT/LNG 


RTEST=( LATMIN.LT. -80  .OR. 
R=RTEST+R 

IF  (RTEST)  WRITE (5,101) 


— TEST  DATA  BASE  DEFINED  LATS ,  LNGS 
LATMIN . GT .80)!  TEST  MINIMUM  LATITIUDE 
!  SET  ERROR  FLAG 
!  OUT  OF  RANGE  ERROR 


RTEST=( LATMAX.LT. -80  .OR. 
R=R+RTEST 

IF  (RTEST)  WRITE (5,102) 


LATMAX.GT.80 ) !  TEST  MAXIMUM  LATITIUDE 
!  SET  ERROR  FLAG 
J  OUT  OF  RANGE  ERROR 


RTEST= ( LATMAX.LT . LATMIN) 
R=R+RTEST 

IF  (RTEST)  WRITE (5, 10 3) 


TEST  LAT  MAX  >  MIN 
SET  ERROR  FLAG 
BOUNDARIES  ERROR 


RTEST= ( LATMAX- LATM I N . LT . 1 0 ) 
R=R+RTEST 

IF  (RTEST)  WRITE (5, 104) 


TEST  RANGE  >10 
SET  ERROR  FLAG 
RANGE  TOO  NARROW 


RTEST= ( LATMAX- LATMIN.GT. 100) 
R=R+RTEST 

IF  (RTEST)  WRITE( 5 , 105) 


!  TEST  RANGE  <  100 
!  SET  ERROR  FLAG 
!  RANGE  TOO  WIDE 


RTEST= ( LNGMIN. LT . - 180  .OR.  LNGMIN.GT. 180 )  !  TEST  MINIMUM  LNG 
R=R+RTEST  !  SET  ERROR  FLAG 

IF  (RTEST)  WRITE (5, 10 6)  !  OUT  OF  RANGE  ERROR 


RTEST= (LNGMAX.LT. -180  .OR.  LNGMAX . GT . 180 )  !  TEST  MAXIMUM  LNG 
R=R+RTEST  !  SET  ERROR  FLAG 

IF  (RTEST)  WRITE (5, 10 7)  !  OUT  OF  RANGE  ERROR 


C-2I.Z 


0119 

RTEST= ( LNGMAX , LT . LNGM I N ) 

!  TEST  LNG  MAX  >  MIN 

0120 

R=R+RTEST 

!  SET  ERROR  FLAG 

*121 

IF  ( RTEST )  WRITE (5, 108) 

!  BOUNDARIES  ERROR 

0122 

0123 

RTEST= ( LNGMAX- LNGM IN. GT . 150 ) 

!  TEST  RANGE  <  150 

0124 

R=R+RTEST 

!  SET  ERROR  FLAG 

0125 

IF  (RTEST)  WRITE (5, 10 9) 

!  RANGE  TOO  WIDE 

0126 

0127 

RTEST = ( LNGMAX- LNGM IN. LT . 10 ) 

!  TEST  RANGE  >10 

0128 

R=R+ RTEST 

!  SET  ERROR  FLAG 

0129 

IF  (RTEST)  WRITE ( 5 , 110 ) 

!  RANGE  TOO  NARROW 

0130 

0131 

GOTO  200 

!  GO  TO  ERROR  SECTION 

0132 

• 

0133 

i - 

— 

-ERROE  MESSAGE  SPECIFICS 

0134 

150 

WRITE (5, 151)  FNAME 

!  FILE  NAME  WITH  ERROR 

0135 

R= . TRUE . 

!  RESET  ERROR  FLAG 

0136 

GOTO  200 

!  SKIP  NEXT  2  LINES 

0137 

152 

WRITE( 5 , 153 )  NDXLEN 

!  DATA  FILES  TOO  BIG  ERROR 

0138 

R= . TRUE . 

!  RESET  ERROR  FLAG 

0139 

200 

RERR=-R 

!  #  OF  ERRORS  IN  INDEX  FILE 

0140 

IF  (R)  WRITE( 5,201)  RERR 

!  DISPLAY  #  OF  ERRORS 

0141 

IF  (R)  THEN 

!  ERROR  EXISTS 

0142 

CLOSE  ( UNIT=4 ) 

!  CLOSE  FILE  4 

0143 

OPEN=. FALSE. 

!  SET  OPEN  FLAG 

0144 

GO  TO  999 

!  RETURN  TO  CALLING  ROUTINE 

0145 

END  IF 

!  END  IF  BLOCK 

0146 

0147 

1 

- TRUNCATE  THE  LATS 

,  LNGS  TO  NEAREST  FIVE  DEGREES 

J 148 

LATMIN=5*LATMIN/5 . 

!  SET  MIN  5  DEGREE  L ATM IN 

0149 

LATMAX=5*LATMAX/5 . 

!  SET  MIN  5  DEGREE  LATMAX 

0150 

LNGM I N= 5* LNGM IN/ 5 . 

!  SET  MIN  5  DEGREE  LNGM IN 

0151 

LNGMAX=5*LNGMAX/5 . 

!  SET  MIN  5  DEGREE  LNGMAX 

0152 

J=MAXDTY* ( LATMAX-LATMIN) * ( LNGMAX-LNGMIN) /2 5  !  GET  #  OF  INDEXES 

0153 

IF  (J.GT. NDXLEN)  GOTO  152 

!  CHECK  NUMBER  OF  LOGICAL  RECS 

0154 

RECMAX= (J+4)/64+l 

!  GET  MAX  NUMBER  OF  RECORDS 

0155 

W=0 

!  #  OF  ITEMS  READ  FROM  FILE 

0156 

0157 

1 - 

- GET  DATA  FROM 

"MAP@B"  FOR  THE  BASE  LAT  &  LNG 

0158 

DO  3  REC= 1 , RECMAX 

!  FOR  MAX  NUMBER  OF  RECORDS 

0159 

K=1 

!  INIT  ITEM  FOR  NOT  1ST  REC 

0160 

IF  (REC.EQ.l)  K=  5 

!  ACCOUNT  FOR  LAT; LNG  MIN;  MAX 

0161 

READ ( 4 1 REC , ERR=  4 )  (RECBUF(I) 

,1=1,64)  !  READ  INDEX  FILE  DATA 

0162 

DO  2  I =K , 64 

!  FOR  EACH  RECORD 

0163 

IF  (W.LT.J)  THEN 

!  #  OF  ITEMS  READ  <  MAXIMUM 

0164 

W=W+1 

!  INCREMENT  *  OF  RECORDS  READ 

0165 

RECNDX ( W ) =RECBUF ( I ) 

!  POINTER  OF  "MAP" (OAC) "A" 

0166 

END  IF 

!  END  IF  BLOCK 

0167 

2 

CONTINUE 

!  END  DO  LOOP 

0168 

3 

CONTINUE 

!  END  DO  LOOP 

0169 

GOTO  8 

0170 

f  - 

TDOAO  D  T?  A  Ti  T  TT  T  T  T?  -T  . 

U  1  /  1 

IjKKUK  K-CjAU  1  JNIj  r  1  J_iHi  —  — 

0172 

4 

WRITE( 5,5) 

!  DATA  BASE  ERROR  MESSAGE 

0173 

DO  6  K=1 , I 

!  DO  FOR  INDEXES  THAT  DO  EXIST 

'll  7  4 

IF  (W.GE.J)  GO  TO  8 

!  #  OF  ITEMS  READ  >=  MAXIMUM 

A75 

W=W+1 

!  INCREMENT  #  OF  RECORDS  READ 

0176 

RECNDX ( W ) =RECBUF ( I ) 

!  POINTER  OF  "MAP" (OAC) "A" 

0177 

6 

CONTINUE 

!  END  DO  LOOP 

c-a  L3 


0178  DO  7  K=W,  J 

179  RECNDX ( I ) =-TW015 

180  7  CONTINUE 

0181  8  CLOSE  (UNIT-4) 

0182  OPEN=. FALSE. 

0183  999  RETURN 

0184 

0185  ! - FORMAT  STATEMENTS 

0186  5  FORMAT (X , 1 **  WARNING  FILE  RECORD  BUFFER  NOT  FILLED,  PADDING  **', 

0187  *  /,X, 5X, 'PROBABLE  DATA  BASE  ERROR') 

0188  101  FORMAT (X, 'MINIMUM  LATITUDE  OUT  OF  RANGE') 

0189  102  FORMAT (X, 'MAXIMUM  LATITUDE  OUT  OF  RANGE') 

0190  103  FORMAT ( X, ' INCONSISTENT  LATITUDE  BOUNDARIES') 

0191  104  FORMAT (X, 'LATITUDE  RANGE  IS  TOO  NARROW') 

0192  105  FORMAT (X, 'LATITUDE  RANGE  IS  TOO  WIDE') 

0193  106  FORMAT (X, 'MINIMUM  LONGITUDE  IS  OUT  OF  RANGE') 

0194  107  FORMAT (X, 'MAXIMUM  LONGITUDE  IS  OUT  OF  RANGE') 

0195  108  FORMAT ( X, ' INCONSISTENT  LONGITUDE  BOUNDARIES  (OR  IDL  CROSSED)') 

0196  109  FORMAT (X, ' LONGITUDE  RANGE  IS  TOO  WIDE') 

0197  110  FORMAT (X, 'LONGITUDE  RANGE  IS  TOO  NARROW') 

0198  151  FORMAT (X, 'ERROR  ENCOUNTERED  IN  READING  DATA  FROM  ' ' ' , 21A1 , ' ' ' ' ) 

0199  153  FORMAT (X, 'ERROR,  OVER  '13'  5  DEGREE  SQUARES  IN  DATA  BASE') 

0200  201  FORMAT ( X , 1 2 ,  '  ERROR ( S )  ENCOUNTERED  IN  INDEX  FILE') 

0201  END 


!  FOR  REMAINDER  OF  INDEX  BLOCK 
!  FILL  WITH  ZEROS 
!  END  DO  LOOP 
!  CLOSE  DATA  FILE 
!  SET  OPEN  ERROR  FLAG 
!  RETURN  TO  CALLING  ROUTINE 


l 
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0005 
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0007 

0008 

0009 
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0011 

0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 

0021 

0022 

0023 

0024 

0025 

0026 

0027 

0028 

<3029 

;030 

0031 

0032 
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0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 
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0046 
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0052 

0053 

0054 

0055 
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0058 

0059 


SUBROUT I NE  GETREC ( SNDX , PNDX , QUAD , DTYPE , NDX , E ) 

PROLOGUE: 

MODULE  NAME:  GETREC 

AUTHOR:  E.  PETR IDES  &  P.  FRAGEORGI A  OF  SYSCON,  INC 

RECODED:  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  1982  &  6/84  (FORTRAN  77) 

FUNCTION:  SUBROUTINE  GET  AND  PROCESS  LOGICAL  RECORD  IS 

DESIGNED  TO  OBTAIN  DATA  FOR  A  5 -DEGREE  SQUARE  AND  CHECK 
ITS  LATITUDE,  LONGITUDE,  AND  DATA  TYPE. 

INPUTS:  LOGICAL  RECORD 
OUTPUTS:  ERROR  MESSAGES  TO  OPERATOR 
MODULES  CALLED:  BMOD 
CALLED  BY:  CRUNCH 


NOTE:  EACH  POLYGON  READ  (IF  THERE  IS  ANY)  IS  CHECKED  FOR  VALIDITY. 
EACH  SEGMENT  OF  THE  SQUARE  IS  ALSO  CHECKED  FOR  VALIDITY. 

DATA  IS  THEN  ASSIGNED  TO  A  TEMPORARY  WORK  BUFFER  TO  BE 
PROCESSED  WITH  OTHER  QUADRANTS  READ  FROM  THE  DATA  BASE. 
ROTATIONAL  ANALYSIS  IS  PERFORMED  ON  EACH  POLYGON  TO  DETER¬ 
MINE  THE  TOTAL  CHANGE  OF  THE  ANGLES  BETWEEN  EACH  POINT  IN 
THE  POLYGON,  THE  POINT  OF  THE  SHIP'S  LOCATION,  &  THE  NEXT 
POINT  IN  THE  POLYGON.  THE  DISTANCE  OF  THE  CLOSEST  POINT 
IN  THE  POLYGON  IS  ASSIGNED  AS  THE  DISTANCE  OF  THE  POLYGON. 


INCLUDE  'MAP. PAR' 

1  PARAMETER  STOLEN=3800 

1  PARAMETER  SEGLEN=60 ,  POLLEN=40  . 

1  PARAMETER  WRKLEN=1000,  NDXLEN=300 

1  PARAMETER  MAXDT Y  =  3 

1  PARAMETER  TOL=3 

1  PARAMETER  DEG=57 . 2957795 

1  PARAMETER  RAD=. 017453293 

1  PARAMETER  PI=3 . 14159265 

1  PARAMETER  ERAD=3440.3 

1  PARAMETER  S251=63001 

1  PARAMETER  TW015=32768 

1 

1  !  INTEGER* 2  MAXDTY , NDXLEN, POLLEN , SEGLEN , STOLEN, TOL ,WRKLEN 

1  !  INTEGER* 4  S251,TW015 

1  !  REAL *4  DEG , ERAD , P I , RAD 

INCLUDE  ' CBT . INC ' 

1  i  - CBT.  INC - 


1  !  VARBL  SIZE  '  PURPOSE  TYPE  RANGE 

1  !  BTRANS  (4,4)  ? 


1  ! 

1  I NTEGER* 2  BTRANS (4,4) 

1 

1  COMMON  /CBT/  BTRANS 

1  I - END  CBT.  INC - 

1 

INCLUDE  ' CLOC . INC ' 

1  j  - CLOC.  INC - 

1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

1  <  BLAT  BASE  LATITUDE  REAL *4 


0060 
0061 
)062 
0063 
0064 
0065 
0066 
0067 
0068 
0069 
0070 
0071 
0072 
0073 
0074 
0075 
0076 
0077 
0078 
0079 
0080 
0081 
0082 
0083 
0084 
0085 
0086 
0087 
0088 
J089 
0090 
0091 
0092 
0093 
0094 
0095 
0096 
0097 
0098 
0099 
0100 
0101 
0102 
0103 
0104 
0105 
0106 
0107 
0108 
0109 
0110 
0111 
0112 
0113 
0114 
0115 
)ll6 
tD  117 
0118 


1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 


BLNG  BASE  LONGITUDE  REAL *4 

LAT  LATITUDE  OF  SHIP'S  LOCATION  REAL*4 

LNG  LONGITUDE  OF  SHIP'S  LOCATION  REAL *4 

NMLT50  #  OF  NAUTICAL  MILES  PER  50TH  DEGREE  REAL *4 

OF  LATITUDE 

NMLG50  #  OF  NAUTICAL  MILES  PER  50TH  DEGREE  REAL *4 

OF  LONGITUDE 


REAL *4  LAT , LNG , BLAT , BLNG , NMLT50 , NMLG5Q 

COMMON  /CLOC/  LAT , LNG , BLAT , BLNG, NMLT50 , NMLG50 

i - END  CLOC. INC - 

INCLUDE  'CLOG. INC' 

i  - CLOG.  INC - 

!  VARBL  SIZE  PURPOSE  TYPE  RANGE 


!  CNVRT (-1:0) 

!  DG 
!  DL 

BYTE  CNVRT ( -1 : 0 ) , DG , DL 


COMMON  /CLOG/  CNVRT ,DL,DG 

- 2ND  CLOG. INC 

INCLUDE  1 CS . INC ' 


!  VARBL  SIZE 

!  S  -1,3800 
!  STOLEN 

REAL *4 


- CS - 

PURPOSE  TYPE  RANGE 


POLYGON  AND  SEGMENT  STORAGE  ARRAY  REALM 

STORAGE  ARRAY  LENGTH  (FOR  SEGS  &  POLYS)  PARM 

S( -1 : STOLEN) 


COMMON  /CS/  S 
- CS-END 


VARBL  SIZE  PURPOSE 


TYPE  RANGE 


BDIV 

BMOD 

CIR 

D 

DTYPE 

E 

I 

IMAX 

J 

K 

N 

NDX 

NPOL 

NSEG 

PLEN 

PNDX  (0:160) 
PTNDX 

Q 

QUAD 

R 


INTERNAL  USER  FUNCTION  NAME 

EXTERNAL  USER  FUNCTION  NAME 

EARTH'S  CIRCUMFERENCE 

ANALYSIS  ALGORITHM 

DATA  TYPE 

ERROR  FLAG 

LOOP  COUNTER 

MAX  LENGTH  OF  STORAGE  ARRAY 
LOOP  COUNTER 
LOOP  COUNTER 

SIGNIFICANT  DIGIT  TRUNCATION 
INDEX 

NUMBER  OF  POLYGONS 
NUMBER  OF  SEGMENTS 
POLYGON  LENGTH 
POLYGON  INDEX 
STORAGE  ARRAY  INDEX 
QUOTIENT 
QUADRANT 

ROTATIONAL  ANGLE 


REAL *4 
REAL *4 
REAL  *4 
REAL *4 
INTEGER* 2 
BYTE 

INTEGER*2 
INTEGER*2 
INTEGER* 2 
INTEGER* 2 
REAL *4 
INTEGER* 4 
INTEGER*2 
INTEGER*2 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
REAL *4 
INTEGER*2 
REAL *4 


0119 

i 

REC 

RECORD  FROM  FILE 

INTEGER* 2 

0120 

i 

RECBUF  (64)  RECORD  BUFFER 

INTEGER* 2 

)121 

i 

• 

SNDX 

(0:240)  SEGMENT  INDEX 

INTEGER* 2 

0122 

j 

T 

FACTOR 

REAL *4 

0123 

i 

TEMP 

FACTOR 

REAL *4 

0124 

i 

Tl 

LENGTH  OF  SEGMENT 

REAL *4 

0125 

t 

T2 

VALUE  OF  CURRENT  POINT 

REAL*4 

0126 

! 

T3 

CURRENT  POLYGON  SEGREFERENCE  REAL *4 

0127 

j 

UACOSD  INTERNAL  USER  FUNCTION  NAME  REAL* 4 

0128 

t 

• 

W 

WORK  BUFFER  INDEX 

INTEGER* 2 

0129 

i 

WLAT 

WORKING  LATITUDE 

INTEGER *2 

0130 

i 

WLEN 

WORK  BUFFER  LENGTH 

INTEGER* 2 

0131 

i 

WLNG 

WORKING  LONGITUDE 

INTEGER* 2 

0132 

I 

• 

WMAX 

WORK  BUFFER  MAXIMUM 

INTEGER* 2 

0133 

! 

• 

WRKBUF  (1000)  WORK  BUFFER 

INTEGER* 2 

0134 

I 

XI 

LONGITUDE  X  FACTOR 

REAL *4 

0135 

i 

X2 

LONGITUDE  X  FACTOR 

REAL *4 

0136 

i 

« 

X3 

LONGITUDE  X  FACTOR 

REAL *4 

0137 

; 

Yl 

LATITUDE  Y  FACTOR 

REAL *4 

0138 

i 

• 

Y2 

LATITUDE  Y  FACTOR 

REAL *4 

0139 

i 

• 

Y3 

LATITUDE  Y  FACTOR 

REAL *4 

0140 

l 

0141 

i 

• 

***  VARIABLES  NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMONS  *** 

0142 

0143 

INTEGER*4  NDX 

0144 

INTEGER* 2  DTYPE , I , I MAX ,  J  ,  K , NPOL , NSEG , PLEN, 

0145 

1  PNDX (0:4*  POLLEN ) , PTNDX , 

QUAD , REC , RECBUF ( 64 ) , 

0146 

2  SNDX( 0 : 4*SEGLEN) ,W,WLAT 

,  WLEN, WLNG, WMAX, 

0147 

3  WRKBUF (WRKLEN) 

)148 

REAL *4  CIR,D,N,Q,R,T, TEMP , Tl , T2 , T3 , XI , X2 , X3 , Yl , Y2 , Y3 , 

0149 

1  UACOSD, BMOD,BD IV 

!  FUNCTIONS 

0150 

BYTE  E 

0151 

0152 

UACOSD (D)=DEG*ACOS(D)  ! 

ARCOSINE  FUNC  USING  DEGREES 

0153 

BDIV ( D , I ) =AINT ( D/FLOATI ( I ) )  ! 

TRUNCATING  D I VI SI ON (REAL/ I NT 

0154 

CIR= ( PI*ERAD) **2  ! 

EARTH'S  CIRCUMFERENCE 

0155 

N=10 . **5  ! 

SIGNIFICANT  DIGIT  TRUNCATION 

0156 

WMAX=WRKLEN  ! 

WORKING  LENGTH 

0157 

E= . FALSE .  ! 

ERROR  FLAG 

0158 

0159 

I 

- GET  work  3UFFER  FROM  "MAP" (OAC) "A"  FILE 

0160 

REC=NDX/ 64+1  I 

DETERMINE  INITIAL  RECORD 

0161 

READ  ( 4 ' REC , ERR= 101)  RECBUF  ! 

GET  INITIAL  RECORD 

0162 

PLEN= 1 1 F I X ( BMOD ( FLO AT J ( NDX ) , 6  4 )  + 1 

.  )  !  POLYGON  LENGTH 

0163 

WLEN=RECBUF ( PLEN )  ! 

GET  WORK  LENGTH 

0164 

IF  ( WLEN. GT. WMAX)  GOTO  103  ! 

IF  RECORD  LEN  TOO  LONG, ERROR 

0165 

W=0  ! 

INITIALIZE  LENGTH 

0166 

DO  1  1=1, WMAX  ! 

FOR  WHOLE  OF  WORK  LENGTH 

0167 

WRKBUF ( I ) =0  ! 

INITIALIZE  WORK  BUFFER 

0168 

l 

CONTINUE  ! 

END  DO  LOOP 

0169 

IF  (PLEN.GE.64)  GOTO  2  ! 

POLYGON  LENGTH  >=  64,  SKIP 

0170 

DO  2  I =PLEN+ 1 , IMIN0 ( 64 , WLEN+PLEN ) 

!  GET  REST  OF  FIRST  BUFFER 

0171 

W=W+1  ! 

WORK  BUFFER  INDEX 

0172 

WRKBUF ( W ) =RECBUF ( I )  ! 

FILL  REST  OF  WORK  BUFFER 

0173 

2 

CONTINUE  ! 

END  DO  LOOP 

0174 

DO  4  I=REC+1 ,REC+ (WLEN-W-l)/64+l ! 

GET  THE  REST  OF  THE  BUFFERS 

>75 

IF  (W.GE.WLEN)  GOTO  5  ! 

INDEX  <  MAX  LENGTH 

0176 

READ  (4 ' I ,ERR=101)  RECBUF  ! 

RESD  REST  OF  DATA  IN  RECORD 

0177 

DO  3  J=1 , IMIN0 ( 64 ,WLEN-W)  ! 

ASSIGN  ONLY  PART  OF  LAST  BUF 

c 


0178  W=W+1  !  INCREMENT  WORK  BUFFER  INDEX 

0179  WRKBUF(W) =RECBUF( J )  !  FILL  WORK  BUFFER 

1180  3  CONTINUE  !  END  DO  LOOP 

0181  4  CONTINUE 

0182  5  IF  (WRKBUF(l) .NE.DTYPE)  GOTO  105!  CHECK  FOR  CORRECT  DATA  TYPE 

0183  !  CHECK  FOR  CORRECT  BASE  LAT 

0184  IF  ( (QUAD.EQ.l.OR.QUAD.EQ.2) . AND . WRKBUF ( 2 ) . NE. I IFIX( BLAT ) +5 )  GOT 

0185  IF  ( (QUAD. EQ. 3. OR. QUAD. EQ. 4) . AND. WRKBUF( 2 ) . NE . I IFIX ( BLAT ) )  GOTO 

0186  WLAT=50* (WRKBUF ( 2 ) -I IFIX( BLAT ) )  !  SET  WORKING  LAT  TO  0  OR  250 

0187  !  CHECK  FOR  CORRECT  BASE  LNG 

0188  IF  ( (QUAD. EQ.l. OR. QUAD. EQ. 3) . AND . WRKBUF ( 3 ) .NE. IIFIX(BLNG) )  GOTO 

0189  IF  ( (QUAD. EQ. 2. OR. QUAD. EQ. 4) . AND . WRKBUF ( 3 ) .NE. I IFIX(BLNG ) +5 )  GOT 

0190  WLNG=50* (WRKBUF ( 3 ) -I I  FIX ( BLNG) )  !  SET  WORKING  LNG  TO  0  OR  250 

0191  NSEG=WRKBUF ( 4 )  !  GET  NUMBER  OF  SEGMENTS 

0192  IF  (NSEG. LT. 1 .OR. NSEG. GT . SEGLEN)  GOTO  111  !  INVALID  #  OF  SEGS 

0193  IF  ( . NOT . DG )  THEN  !  POLYGON  DATA 

0194  IF  (NSEG.LT.4)  GOTO  111  !  INVALID  #  OF  SEGMENTS 

0195  NPOL=WRKBUF ( 5 )  !  GET  NUMBER  OF  POLYGONS 

0196  IF  (NPOL.LT.l. OR. NPOL.GT. POLLEN)  GOTO  113  !  INVALID  NUMBER 

0197  END  IF  !  END  IF  BLOCK 

0198 

0199  ! - STORE  NUMBER  OF  SEGMENTS  IN  THIS  QUADRANT 

0200  W=4+CNVRT(DL)  !  WORK  BUFFER  INDEX 

0201  I=IIFIX(S(0) )  !  START  OF  STORAGE  ARRAY 

0202  IMAX= IIFIX(S(-1) )  !  MAX  LENGTH  OF  STORAGE  ARRAY 

0203  DO  11  J= 1+4 *CNVRT ( DL ), NSEG  !  FOR  NUMBER  OF  SEGMENTS 

0204  Tl=FLOATI (WRKBUF (W+l) )  !  GET  LENGTH  OF  SEGMENT 

0205  IF  (T1.LT.2. .OR.T1.GT. 150 . )  GOTO  115  !  INVALID  SEGEMNT 

0206  IF  (Tl+1 . +CNVRT(DG) .GT. FLOATI (WMAX-W) )  GOTO  117  !  OVERFLOW  WOR 

/207  IF  (Tl+4 . +CNVRT ( DG) .GT . FLOATI ( IMAX-I ) )  GOTO  119  !  OVERFLOW  STO 

0208  S ( 1+1 ) =T1  !  ASSIGN  LENGTH  OF  SEGMENT 

0209  IF  ( DG. AND. WRKBUF (W+ 2) .LT.-l)  GOTO  121  !  NON-POLYGON 

0210  IF  (DG)  S ( 1+4 )= FLOAT I ( WRKBUF ( W+2 ) )  !  SEG  CODE  FOR  CONTOUR  D 

0211  DO  10  K-l, IIFIX(Tl)  !  GET  REST  OF  PTS  IN  SEGMENT 

0212  T2=WRKBUF( W+l+K+CNVRT ( DG) )+TW015  !  VALUE  OF  CURRENT  PT 

0213  IF  (T2.GE.S251)  GOTO  123  !  CHECK  AND  STORE  POINT 

0214  PTNDX = I +4+CNVRT ( DG ) +K  !  STORAGE  ARRAY  INDEX 

0215  S ( PTNDX) =50 1 .*(BDIV(T2,251) +FLOATI ( WLAT ) ) +BMOD ( T2 , 251 ) +FLOAT 

0216  IF  (K.LE.l)  THEN  !  FIRST  TIME  THROUGH 

0217  R=0 .  !  INITIAL  DATA  FOR  ROTATIONAL 

0218  D=CIR  !  ANALYSIS  ALGORITHM; SEE  PD I ST 

0219  X2=(BMOD(S( PTNDX) , 501 ) -LNG) *NMLG50  !  LONG  X  FACTOR 

0220  Y2= ( BDI V( S ( PTNDX ) ,501) -LAT ) *NMLT50  !  LAT  Y  FACTOR 

0221  IF  (DG)  S( 1+5) =S( PTNDX)  !  UPDATE  STORAGE  ARRAY 

0222  ELSE  !  NOT  FIRST  TIME  THROUGH 

0223  IF  (D.LT.0.25)  GOTO  10  !  ANALYSIS  ALGORITHM  <.25 

0224  X1=X2  !  LONGITUDE  X  FACTOR 

0225  Y1=Y2  !  LATITUDE  Y  FACTOR 

0226  X2= (BMOD(S( PTNDX) ,501) -LNG) *NMLG50  !  LONG  X  FACTOR 

0227  Y2= ( BDI V ( S ( PTNDX ) , 501 ) -LAT) *NMLT50  !  LAT  Y  FACTOR 

0228  X3=X2-X1  !  LONGITUDE  X  FACTOR 

0229  Y3=Y2-Yl  !  LATITUDE  Y  FACTOR 

0230  IF  (X3.EQ.0. . AND . Y3 . EQ . 0 . )  GOTO  10  !  LAT  &  LNG  =  0 

0231  Q=-(X1*X3+Y1*Y3)/(X3**2+Y3**2)  !  QUOTIENT 

0232  IF  (Q.LE.0.)  T=X1**2+Y1**2  !  FACTOR 

"1233  IF  (Q.GT.O  .  .AND.Q.LT.l.  )  T= (X1+Q*X3 ) **2+ ( Y1+Q*Y3 ) **2  !  F 

>234  IF  (Q.GE.l.)  T=X2**2+Y2**2  !  FACTOR 

0235  IF  (D.GT.T)  THEN  !  DISTANCE  >  T 

0236  D=T  !  RESET  DISTANCE 


C-22  M 


0237 
0238 
0239 
0240 
0241 
0242 
0243 
0244 
0245 
0246 
0247 
0248 
0249 
0250 
0251 
0252 
0253 
0254 
0255 
0256 
0257 
0258 
0259 
0260 
0261 
0262 
0263 
0264 
9265 
4266 
0267 
0268 
0269 
0270 
0271 
0272 
0273 
0274 
0275 
0276 
0277 
0278 
0279 
0280 
0281 
0282 
0283 
0284 
0285 
0286 
0287 
0288 
0289 
0290 
0291 
1292 
i  293 
0294 
0295 


10 


11 


IF  (DG)  S( 1+5 ) =S(PTNDX)  !  POLYGON  DATA 
END  IF  !  END  IF  BLOCK 

T=SQRT ( (X1**2+Y1**2)*( X2**2+Y2**2 ) )  !  FACTOR 


IF  (AINT(T*N)/N.EQ 
D-0. 

R=0 . 

GOTO  10 
END  IF 


,0.  ) 


THEN  !  ZERO  DISTANCE 
!  SET  DISTANCE  TO  ZERO 
!  SET  ROTATION  ANGLE  TO 
!  SKIP  NEXT 
!  END  IF  BLOCK 

i 


TEMP=UACOSD(AINT( ( (Xl*X2+Yl*Y2)/T)*N)/N)  !  FACTOR 
IF  (X2*Y1.NE.Y2*X1)  R=R+SIGN(TEMP, ( X2*Y1-Y2*X1 ) )  ! 


ROT  AN 


END  IF 
CONTINUE 
S( 1+2 ) =R 
S ( 1+3 ) =D 

SNDX ( J +SNDX ( 0 ) )=I  +  1 
W=W+I IFIX(T1 ) +1+CNVRT ( DG) 
I=I+IIFIX(Tl) +4+CNVRT ( DG ) 
CONTINUE 
IF  (DG)  THEN 

SNDX ( 0 ) =SNDX ( 0 ) +NSEG 
GOTO  _  1 5 
END  IF 


END  IF 
END  DO  LOOP 

STORE  SUM  OF  ROT  ANGLES 

ASSIGN  DIST  TO  NEAREST  POINT 

UPDATE  SEGMENT  INDEX 

UPDATE  WORK  STORAGE  BUFF  LEN 

UPDATE  STORAGE  ARRAY  LENGTH 

END  DO  LOOP 

IF  NON-POLYGON  DATA 

UPDATE  LEN  OF  SEG  INDEX  ARRAY 

SKIP  POLYGON  PROCESSING 

END  IF  BLOCK 


12 


13 


14 

15 


DO  14  J=1 ,NPOL 

Tl=FLOATI (WRKBUF ( W+2 ) ) 


-STORE  POLYGONS  OF  THIS  QUADRANT 
!  FOR  ALL  POLYS  IN  SQUARE 
!  #  OF  SEG  REFS  IN  POLYGON 


IF  (Tl.LT.l. .OR.T1.GT.25. )  GOTO  125!  ERROR;  BEYOND  MAX; MIN 
T2 =FLOAT I (WRKBUF (W+3) )  !  #  OF  LABLE  PTS  IN  POLYGON 

IF  (T2.LT.0. .OR.T2.GT.5. )  GOTO  127  !  INVALID;  BEYOND  MAX /MIN 
IF  (T1+T2+3 . .GT . FLOAT I ( WMAX-W) )  GOTO  117  !  ERROR; OVERFLOW  WOR 
IF  (T1+T2+3 . .GT. FLOAT I ( IMAX- I ) )  GOTO  119  !  ERROR;  OVERFLOE  ST 
S ( 1+1 ) =FLOATI (WRKBUF ( W+l ) )  !  STORE  POLYGON  INDEX  CO 


S( I+2)-Tl 
S(  I  +  3)=T2 

DO  12  K=4 , IIFIX(Tl)+3 
T3=FLOATI (WRKBUF (W+K ) ) 


STORE  #  OF  POLY  SEG  REFS 
STORE  #  OF  LABEL  PTS 
PROCESS  POLY  SEG  REFERENCES 
CURRENT  POLY  SEG  REFERENCE 
IF ( ABS (T3 ) . GT . FLOAT I (NSEG ) . OR . T3 . GT . -5 . . AND . T3 . LT . 1 . )  GOTO  1 
IF(ABS(T3) . GT . 4 . )  T3=SIGN( FLOAT ( SNDX ( I ABS ( I IFIX(T3 ) ) ) ) ,T3) 

I F ( ABS ( T 3 ) . LE . 4 . )  T3=FLOATI ( BTRANS (QUAD, T3 ) )  !  INERIOR  BORDE 
S ( I +K) =T3  !  STORE  POLY  SEG  REFERENCE 

CONTINUE  !  END  DO  LOOP 

DO  13  K=IIFIX(Tl)+4, IIFIX(Tl+T2)+3  !PROCESS  POLYGON  LABEL  POIN 
T3=WRKBUF(W+K) +TW015  !  STORE  LABEL  PT  FOR  CURR  POLY 

IF  (T3.GE.S251)  GOTO  131  !  ERROR  IN  LABEL  POINT  BRANCH 

S(I+K)=501.*(BDIV(T3,251) + FLOAT I ( WLAT ) ) +BMOD(T3 , 251) +FLOATI ( 


CONTINUE 

PNDX ( PNDX ( 0 ) + J ) = I + 1 
I=I+IIFIX(Tl+T2)+3 
W=W+ IIFIX(Tl+T2)+3 
CONTINUE 

PNDX ( 0 ) =PNDX ( 0 ) +NPOL 
S ( 0 ) = FLOAT I ( I ) 

GO  TO  999 


END  DO  LOOP 

UPDATE  POLYGON  INDEX  COUNT 
UPDATE  STORAGE  ARRAY  LENGTH 
UPDATE  WORK  BUFFER  LENGTH 
END  DO  LOOP 
UPDATE  POLYGON  INDEX 
STORAGE  ARRAY  START 
RETURN  TO  CALLING  ROUTINE 


m 

103 


WRITE (5,102) 
GOTO  150 
WRITE( 5,104) 
GOTO  150 


ERRORS - 

!  RECORD  LENGTH  TOO  LONG 
!  GO  DISPLAY  QUADRANT  &  RETURN 
!  END  OF  FILE  ENCOUNTERED 
!  GO  DISPLAY  QUADRANT  &  RETURN 


OS2...T 


0296 

105 

0297 

0298 

107 

0299 

0300 

109 

0301 

0302 

111 

0303 

0304 

113 

0305 

0306 

115 

0307 

0308 

117 

0309 

0310 

119 

0311 

0312 

121 

0313 

0314 

123 

0315 

0316 

125 

0317 

0318 

127 

0319 

0320 

129 

0321 

0322 

131 

0323 

150 

0324 

1)325 

0326 

999 

0327 

0328 

! 

0329 

102 

0330 

104 

0331 

106 

0332 

108 

0333 

110 

0334 

112 

0335 

114 

0336 

116 

0337 

118 

0338 

120 

0339 

122 

0340 

124 

0341 

126 

0342 

128 

0343 

130 

0344 

132 

0345 

151 

0346 

152 

0347 

153 

0348 

WRITE ( 5 , 106 ) 

GOTO  150 
WRITE (5,108) 

GOTO  150 
WRITE (5,110) 

GOTO  150 
WRITE (5,112) 

GOTO  150 
WRITE (5,114) 

GOTO  150 
WRITE (5,116) 

GOTO  150 
WRITE (5,118) 

GOTO  150 
WRITE (5,120) 

GOTO  150 
WRITE{ 5,122) 

GOTO  150 
WRITE (5,124) 

GOTO  150 
WRITE (5,126) 

GOTO  150 
WRITE( 5,128) 

GOTO  150 
WRITE(5, 130) 

GOTO  150 
WRITE (5,132) 

WRITE (5,151)  QUAD, IIFIX(BLAT) , 
WRITE( 5,152) 

READ (5,153) 

RETURN 


.  !  WRONG  OR  MISSING  RECORD  ID 
!  GO  DISPLAY  QUADRANT  &  RETURN 
!  WRONG  OR  MISSING  LATITUDE  ID 
!  GO  DISPLAY  QUADRANT  &  RETURN 
!  WRONG  OR  MISSING  LNG  ID 
!  GO  DISPLAY  QUADRANT  &  RETURN 
!  INVALID  #  OF  SEGMENTS 
!  GO  DISPLAY  QUADRANT  &  RETURN 
!  INVALID  NUMBER  OF  POLYGONS 
!  GO  DISPLAY  QUADRANT  &  RETURN 
!  INVALID  #  OF  PTS  IN  SEGMENT 
!  GO  DISPLAY  QUADRANT  &  RETURN 
!  WORK  BUFFER  OVERFLOW 
!  GO  DISPLAY  QUADRANT  &  RETURN 
!  STORAGE  ARRAY  OVERFLOW 
!  GO  DISPLAY  QUADRANT  &  RETURN 
!  INVALID  SEGMENT  CODE 
!  GO  DISPLAY  QUADRANT  &  RETURN 
!  INVALID  POINT  LAT/LNG  CODE 
!  GO  DISPLAY  QUADRANT  &  RETURN 
!  INVALID  #  OF  SEGS  IN  POLYGON 
!  GO  DISPLAY  QUADRANT  &  RETURN 
!  INVALID  #  OF  LABELS  IN  POLY 
!  GO  DISPLAY  QUADRANT  &  RETURN 
!  INVALID  SEGMENT  REFERENCE 
!  GO  DISPLAY  QUADRANT  &  RETURN 
!  INVALID  LABEL  LAT/LNG  CODE 
IFIX(BLNG)  !  ERROR  IN  QUADRANT  # 
!  PAUSE  (RETURN  TO  CONTINUE) 

!  READ  OPERATOR  CONTINUE  SIGN 
!  RETURN  TO  CALLING  ROUTINE 


FORMAT  STATEMENTS - 

FORMAT( 5X, 'SPECIFIED  RECORD  LENGTH  TOO  LONG,  IN  GETREC') 
FORMAT ( 5 X, ’END  OF  FILE  ENCOUNTERED') 

FORMAT(5X, 'WRONG  OR  MISSING  RECORD  IDENTIFICATION') 

FORMAT( 5X, 'WRONG  OR  MISSING  LATITUDE  IDENTIFICATION') 

FORMAT ( 5X ,' WRONG  OR  MISSING  LONGITUDE  IDENTIFICATION’) 
FORMAT (5X, ' INVALID  NUMBER  OF  SEGMENTS') 

FORMAT ( 5X, ' INVALID  NUMBER  OF  POLYGONS') 

FORMAT ( 5X, ' INVALID  NUMBER  OF  POINTS  IN  SEGMENT') 

FORMAT ( 5X , ' WORK  BUFFER  OVERFLOW') 

FORMAT ( 5 X, 'STORAGE  ARRAY  OVERFLOW') 

FORMAT (5X, ' INVALID  SEGMENT  CODE' ) 

FORMAT ( 5X, ' INVALID  POINT  LATITUDE  OR  LONGITUDE  CODE') 

FORMAT ( 5X, ' INVALID  NUMBER  OF  SEGMENTS  IN  POLYGON’) 
FORMAT(5X, ' INVALID  NUMBER  OF  LABELS  IN  POLYGON') 

FORMAT ( 5X, ' INVALID  SEGMENT  REFERENCE') 

FORMAT(5X, ' INVALID  LABEL  LATITUDE  OR  LONGITUDE  CODE') 

FORMAT (5X, 'ERROR  IN  QUADRANT  I 1 , '  (',14, ',',14')  !  BEL’) 
FORMAT(X, ' PAUSE  (HIT  RETURN  TO  CONTINUE) '$) 

FORMAT ( ) 

END 


C-J22.£ 


0001 

0002 

)003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 

0011 

0012 

0013 

0014 


0029 
)0  30 
0031 
0032 
0033 
0034 
0035 
0036 
0037 
0038 
0039 
0040 
0041 
0042 
0043 
0044 
0045 
0046 
0047 
0048 
0049 
0050 
0051 
0052 
0053 
0054 
0055 
0056 
)057 
0058 
0059 


SUBROUTINE  GLITCH (NBT , NDLYR) 

PROLOGUE : 

MODULE  NAME:  GLITCH 

AUTHOR:  STEPHEN  LAFLEUR,  CODE  3333,  NUSC/NLL 
DATE:  18  SEP  84 

FUNCTION:  REMOVE  GLITCHES  BELOW  THE  LAYER 

INPUTS:  PARAMETERS  PASSED  IN  AND  VARIABLES  IN  COMMONS. 

OUTPUTS : 

MODULES  CALLED:  NONE 
CALLED  BY:  XBT 


INCLUDE  ' DTV. INC ' 


-DTV- 


0015 

0016 

1 

1 

J 

J 

VARBL 

SIZE 

PURPOSE 

TYPE 

0017 

1 

1 

D 

(25) 

DEPTH 

REAL *4 

0018 

1 

i 

DD 

(25) 

DEPTH 

REAL *4 

0019 

1 

j 

NNBT 

NUMBER  OF  BATHETHERMAL  INTEGER* 2 

0020 

1 

1 

T 

(25) 

TEMPERATURE 

REAL *4 

0021 

1 

; 

TT 

(25) 

TEMPERATURE 

REAL *4 

0022 

1 

i 

VEL 

(25) 

VELOCITY 

REAL *4 

0023 

1 

[ 

0024 

1 

INTEGER 

*2  NNBT 

0025 

1 

REAL *4 

D , DD , T , TT , VEL 

0026 

1 

0027 

1 

COMMON 

/DTV/  D ( 2  5 ) 

, T  ( 2 5 ) , VEL (25) ,DD(25) ,TT( 

0028 

1 

i 

— 

- END  DTV - 

RANGE 


VARBL  SIZE 


I 

IP 

L 

NBB 

NBT 

NDLYR 


(25) 


PURPOSE 

COUNTER 

POSITIVE  OR  NON-POSITIVE  FLAG 
COUNTER 

NUMBER  OF  BT  POINTS  -  3 
NUMBER  OF  BT  POINTS 
BT  LAYER'S  POSITION  IN  ARRAY 


TYPE 

INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
INTEGER*2 
INTEGER* 2 


RANGE 


0  OR  1 


***  VARIABLES  NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMONS  *** 

INTEGER* 2  I , IP, L, NBB, NBT, NDLYR 
DIMENSION  I P ( 2 5 ) 

- DETERMINE  POSITIVE(l)  AND  NEGATIVE(-l)  GRADIENTS  BETWEEN  POINTS 


200 


DO  200  1=1 , NBT-1 
IP ( I ) =1 

I F ( VEL ( I + 1 ) - VEL ( I )  .LE.0.  )  IP( l)=-l 
CONTINUE 


FOR  FOR  #  OF  BT  -  1 
POSITIVE  GRADIENT 
NEGATIVE  GRADIENT 
END  DO  LOOP 


- REMOVE  ANY  GLITCHES  BELOW  THE  LAYER. 

- THERE  ARE  NO  GLITCHES  ABOVE  THE  LAYER  BECAUSE  THE  LAYER 

- DEPTH  POINT  IS  THE  POINT  BEFORE  THE  FIRST  NEGATIVE  GRADIENT. 

NBB=NBT-3  !  DETERMINE  END  OF  DO  LOOP 

DO  250  I=NDLYR, NBB  !  BEGIN  DO  LOOP 

255  IF( IP ( I ) .NE. IP ( 1+1) .AND. IP( 1+1) .NE. IP( 1+2) )  THEN 

NBT=NBT-1  !  REMOVE  3RD  POINT  IN  4 

DO  260  L=I+2 ,NBT  !  DO  UNTIL  #  OF  BT 

D ( L ) =D( L+ 1 )  !  DEPTH 


C-23.1 


0060 

VEL ( L ) =VEL ( L+l ) 

!  VELOCITY 

0061 

ip(l)=ip(l+i) 

!  GRAD I ANT 

006 

260 

CONTINUE 

!  END  DO  LOOP 

0063 

IP( I+l)=l 

!  CALCULATE  GRADIENT  SIGN 

0064 

IF (VEL ( I +2 ) -VEL ( 1  +  1 ) .LE.0. ) 

IP ( 1+1 ) =-l 1  IN  NEW  LINE  SEG 

0065 

I F ( I . LT . NBB ) GOTO  255 

!  RECHECK  NEW  3RD  POINT 

0066 

END  IF 

!  END  IF  BLOCK 

0067 

250 

CONTINUE 

!  END  DO  LOOP 

0068 

RETURN 

!  BACK  TO  CALLING  ROUTINE 

0069 

END 

!  END  SUBROUTINE 

:OMMAND  QUALIFIERS 

FORTRAN  /CHECK=ALL/L I ST/SHOW3 ( INCLUDE , NOMAP )  [LAFLEUR] GLITCH. F77 

/CHECK3 ( BOUNDS , OVERFLOW , UNDERFLOW ) 

/DEBUG3 ( NOSYMBOLS , TRACEBACK ) 

/STANDARD3  ( NOSYNTAX ,  NOSOURCE__FORM ) 

/SHOW3 ( NOPREPROCESSOR , INCLUDE , NOMAP ) 

/F77  /NOG  FLOATING  /I4  /OPTIMIZE  /WARNINGS  /NOD  LINES  /NOCROSS  REFERENCE 


OMPILATION  STATISTICS 


Ri  )Time: 
Elapsed  Time: 
Page  Faults: 
Dynamic  Memory 


1 . 14  seconds 
1.75  seconds 
314 

126  pages 


C  -23  ^ 


0119 

0120 

P121 


!  XMIN 
!  XOFF 
!  XSCALE 
!  Y 

!  YMAX 
!  YMIN 

i  yoff 

!  YSCALE 


DATA  BASE  MINIMUM  X 
X-AXIS  OFFSET 
X  PROGRAM  SCALE 

Y  COORDINATE 

DATA  BASE  MAXIMUM  Y 
DATA  BASE  MINIMUM  Y 
Y-AXIS  OFFSET 

Y  PROGRAM  SCALE 


REAL *4 
INTEGER* 2 
REAL *4 
INTEGER*2 
REAL *4 
REAL *4 
INTEGER* 2 
REAL *4 


i  ***  VARIABLES  NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMONS  *** 

REAL  *  4  A , AX , AY , BD I V , BMOD , SCALE , SRAD , USRCOS , USRS I N , USRTAN 
REAL *4  XMIN , XMAX , XSCALE , YMIN , YMAX , YSCALE 
INTEGER* 2  DTYPE , FNP , I , IX, IY, J ,K, L, LEN,M,N 
I NTEGER*  2  SGN , SS , X , XOFF , XVAL , Y , YOFF , YVAL 
INTEGER*4  C , HYP , STAR , TITLE ( 5 ) 

BYTE  BOUND ( 5 ) ,TXT(5) , INTER( 5) , ISTR(5) , D I R , LAND , UNMARK 
DATA  HYP , STAR  / '  -  ’  , '  *  ’  / 

DATA  BOUND  /,B,f,o,r,U,f,n'r,d'/ 

DATA  INTER  /T/n'/t'/e'/r'/ 

DATA  SRAD  /60/ 


USRTAN ( A ) = DEG* TAN ( RAD* A ) 

USRCOS (A) =COS ( RAD* A) 

USRSIN( A) =SIN( RAD* A) 

BDI V ( A, I ) =AINT ( A/ FLOAT ( I ) ) 

IX(A)=NINT( ( A-XMIN) *XSCALE) +XOFF 
I Y( A) =NINT ( ( A-YMIN) *YSCALE) +YOFF 
XVAL (A) = IX ( BMOD ( A ,501) ) 

YVAL (A) =1 Y (USRTAN { BDIV ( A, 501 ) /50+BLAT ) 


SCALE=360 
XOFF=247 
YOFF=30 
XMIN=0 
XMAX=  500 

YMI N=USRTAN ( BLAT ) 
YMAX=USRTAN ( BLAT+1 0 ) 
YSCALE=SCALE/ ( YMAX-YMIN ) 
XSCALE=SCALE/ { XMAX-XMIN ) 
CALL  INITT ( 2 ) 


FUNCTIONS - 

!  TANGENT  FUNCT  USING  DEG 
!  COSINE  FUNCTION  USING  D 
!  SINE  FUNCTION  USING  DEG 
!  TRUNCATING  DIVISION  (RE 
!  X  SCALE  FUNCTION 
!  Y  SCALE  FUNCTION 
!  SCALED  501  MODULO  X  VAL 
!  SCALED  501  DIV  Y  VALUE 

INITIALIZE - 

!  DISPLAY  BOX  SCALE  (RAST 
!  X-AXIS  OFFSET  FOR  THE  B 
!  Y-AXIS  OFFSET  FOR  THE  B 
!  DATA  BASE  MIN  X  PARAMET 
!  DATA  BASE  MAX  X  PARAMET 
!  DATA  BASE  MIN  Y  PARAMET 
!  DATA  BASE  MAX  Y  PARAMET 
!  PROGRAM  SCALES  (10  X  10 
!  PROGRAM  SCALES  (10  X  10 
!  INITIALIZE  GRAPHICS  MOD 


-DEFINE  PLOTTING  AREA  BY  FRAMING  DISPLAY  AREA  &  DRAWIN 


CALL  MOVE ( IX(XMIN) , IY(YMIN) ) 

CALL  DRAW( IX(XMIN) , IY(YMAX) ) 

CALL  DRAW ( I X ( XMAX ) , I Y ( YMAX ) ) 

CALL  DRAW( IX(XMAX) , IY(YMIN) ) 

CALL  DRAW ( IX (XMIN) , I Y (YMIN) ) 

CALL  MOVE( IX ( (XMAX+XMIN) /2 ) , IY(YMIN) ) 
CALL  DRAW ( IX ( (XMAX+XMIN )/2) ,IY(YMAX)) 
CALL  MOVE ( IX ( XMIN) , I Y ( USRTAN ( BLAT+5 ) ) ) 
CALL  DRAW ( IX(XMAX) , IY( USRTAN( BLAT+5 ) ) ) 


DO  1  1= ( OAC-1 ) *5+1 ,OAC*5 
J=J+1 


!  MOVE  PEN  TO  THESE  COORD 
!  DRAW  LINE  UP 

!  DRAW  LINE  TO  RIGHT 

!  DRAW  LINE  DOWN 

!  DRAW  LINE  TO  LEFT 

!  MOVE  PEN 

1  DRAW  GRID  LINE 
!  MOVE  PEN 
!  DRAW  GRID  LINE 

GET  GRAPH  TITLE - 

!  INITIALIZE  INDEX 
!  DO  FOR  OCEAN  NAME  ARRAY 
!  INCREMENT  INDEX 


C-a  V‘3 


0178  TITLE  (J )  =ONAME  ( I )  !  SET  OCEAN  NAME  TEXT 

0179  1  CONTINUE  !  END  DO  LOOP 

1)180 

0181  ! - SHOW  SHIP  AS  A  CROSS  IN  C  - 

0182  SS=3  !  SET  SHIP  SIZE  (RASTERS) 

0183  X=IX(LNG)  !  X  COORDINATE 

0184  Y=IY(USRTAN( LAT/50+BLAT ) )  !  Y  COORDINATE 

0185  CALL  MOVE ( X , Y-SS )  !  MOVE  PEN 

0186  CALL  DRAW(X, Y+SS)  !  DRAW  HALF  OF  CROSS 

0187  CALL  MOVE(X-SS,Y)  !  MOVE  PEN 

0188  CALL  DRAW(X+SS,Y)  !  FINISH  DRAWING  CROSS  f 

0189  DO  2  1=30,360,30  !  DRAW  CIRCLE 

0190  CALL  DRAW( X+NINT (USRS IN( FLOAT I ( I ) ) * FLOAT I ( SS ) ) , 

0191  1  Y+NINT ( USRCOS ( FLOATI ( I ) ) *FLOATI ( SS ) ) ) 

0192  2  CONTINUE  !  END  DO  LOOP 

0193 

0194  ! - DRAW  STEAMING  RADIUS - 

0195  AX= ( SRAD/NMLG50 ) * . 95  !  SET  X  COORDINATE 

0196  AY= ( SRAD/ ( NMLG50  * 50 . ) ) * .  95  !  SET  Y  COORDINATE 

0197  CALL  LNTYPE ( 2 )  !  DOTTED  LINE  TYPE 

0198  .  CALL  MOVE ( IX( LNG) , I Y ( USRTAN ( LAT/50+BLAT+USRTAN( AY ) ) ) )  !  MOVE  PEN 

0199  DO  3  1=5,360,5  !  DO  FOR  360  DEGREES 

0200  CALL  DRAW ( I X ( LNG+USRS I N ( FLOAT I ( I ) ) * AX ) ,  !  DRAW  STEAMING  RADIUS 

0201  *  I Y ( USRTAN ( LAT/50 . +BLAT+ USRTAN ( AY*USRCOS ( FLOATI ( I ) ) ) ) ) ) 

0202  3  CONTINUE  !  END  DO  LOOP 

0203  CALL  LNTYPE ( 1 )  !  DRAW  DATA  TYPE  FROM  DAT 

0204 

0205  ! - DRAW  POLYGONS  AND  LABELS - 

0206  IF  (DTYPE.LE.2)  THEN  !  IF  POLYGON  DATA 

il207  SGN=0  !  INITIALIZE 

0208  DO  25  I=IIFIX(S(0))+1,IIFIX(S(0)+S(IIFIX(S(0))))  !  DRAW  ALL  PO 

0209  N=IIFIX(S( I ) )  !  IN  THE  10  DEG SQUARE  A 

0210  DO  22  J=N+3 , N+I I  FIX ( S (N+l ) ) +2  !  THE  ORDER  OF  THEIR  DIST 

0211  K= I I ABS ( IIFIX(S(J) ) )  !  FROM  SHIP'S  LOCATION 

0212  IF  ( K . GT .12. AND ,IIFIX(S(K)). GE . 2 )  THEN  !  VALID  VALUES 

0213  L=FNP( IIFIX(S( J) ) )  !  LOCATION  OF  SHIP 

0214  CALL  MOVE ( XV AL ( S ( L ) ) , YVAL ( S ( L ) ) )  !  MOVE  PEN 

0215  I F ' ( S ( J ) . NE . 0 . )  SGN= 1 1  FIX ( SIGN( 1 . , S ( J ) ) )  !  SIGN 

0216  DO  21  M=L+SGN, FNP( IIFIX(-S(J) ) ) , SGN  !  IN  ORDER  OF  DIST 

0217  CALL  DRAW(XVAL(S(M) ) ,YVAL(S(M) ) )  !  DRAW  POLYGON 

0218  21  CONTINUE  !  END  DO  LOOP 

0219  S(K)=-S(K)  !  MAKE  VALUE  NEGATIVE 

0220  END  IF  !  END  IF  BLOCK 

0221  22  CONTINUE  !  END  DO  LOOP 

0222  DO  24  J=N+I IFIX ( S (N+l ) ) +3 , N+ 1 1  FIX ( S ( N+l ) )  + 1 1  FIX ( S ( N+ 2 ) )+2  ! 

0223  IF  (S(N+2) .NE.0.  .AND.  S(N).GT.0.)  THEN  !  VALID  VALUES 

0224  CALL  MOVE ( XVAL ( S ( J ) ) , YVAL ( S ( J ) ) )  !  MOVE  PEN 

0225  LEN=I IFIX ( LOG10 ( AMAX1 (S(N),1.)))+1  !  LENGTH  OF  STRING 

0226  ENCODE ( LEN ,23,1 STR )  IIFIX(S(N))  !  ENCODE  STRING 

0227  CALL  TEXT (LEN, I STR)  !  DRAW  LABEL 

0228  END  IF  !  END  IF  BLOCK 

0229  24  CONTINUE  !  END  DO  LOOP 

0230  25  CONTINUE  !  END  DO  LOOP 

0231 

0232  ! - DRAW  CONTOURS  FOR  NON-POL 

9233  ELSE  !  FOR  NON- POLYGON  DATA 

J 234  DO  11  I=IIFIX(S(0) )+l,IIFIX(S(0)+S(lIFIX(S(0) ) ) )  !  FOR  SEG  STO 

0235  J  =  FNP (IIFIX(S(I)))  +  1  !  SET  INDEX 

0236  CALL  MOVE ( XVAL ( S ( J ) ) , YVAL ( S ( J ) ) )  !  MOVE  PEN 


c  -aw.V 


0237 

DO  10  K=J+1 , FNP (IIFIX(-S(I)))+1 

i 

• 

DRAW  BOTTOM  DEPTH 

0238 

CALL  DRAW ( XV AL ( S ( K ) ) , YVAL ( S ( K ) ) ) 

i 

• 

CONTOURS 

)239 

10 

CONTINUE 

i 

END  DO  LOOP 

0240 

11 

CONTINUE 

! 

END  DO  LOOP 

0241 

END  IF 

i 

END  IF  BLOCK 

0242 

0243 

• 

r  a  Dtrr 

GRAPH'S  LATITUDE  AND  LO 

I 

Lino 

0244 

DO  31  I  =  I IFIX ( BLAT ) , I  IF IX( BLAT ) +10 , 5 

i 

• 

LABEL  LAT  ON  LEFT  SIDE 

0245 

IF  (I.GT.0)  D I R= ' N ' 

; 

NORTH  FOR  POSITIVE 

0246 

IF  (I.LT.0)  D I  R=  '  S  ' 

i 

• 

SOUTH  FOR  NEGATIVE 

0247 

IF  (I.EQ.0)  DIR=0 

; 

EQUATOR  SET  TO  NULL 

0248 

CALL  MOVE ( XOFF-28 , I Y ( USRT AN ( FLOAT I ( I ) 

) ) )  !  MOVE  PEN 

0249 

ENCODE (3,10002,ISTR)  IABS(l),DIR 

i 

• 

ENCODE  STRING 

0250 

CALL  TEXT (3,1 STR) 

i 

« 

LABEL 

0251 

31 

CONTINUE 

i 

• 

END  DO  LOOP 

0252 

DO  32  I = I IFIX ( BLAT ) , I I F IX ( BLAT ) +10 , 5 

i 

• 

LABEL  LAT  ON  RIGHT  SIDE 

0253 

IF  (I.GT.0)  DIR='N' 

i 

NORTH  FOR  POSITIVE 

0254 

IF  (I.LT.0)  D I R= ' S ' 

i 

• 

SOUTH  FOR  NEGATIVE 

0255 

IF  (I.EQ.0)  DIR=0 

i 

EQUATOR  SET  TO  NULL 

0256 

CALL  MOVE (XOFF+ 37 4,1 Y (USRT AN( FLOATI(I) )) )  !  MOVE  PEN 

0257 

ENCODE (3,10002,ISTR)  IABS(I),DIR 

i 

ENCODE  STRING 

0258 

CALL  TEXT (3, I STR) 

i 

• 

LABEL 

0259 

32 

CONTINUE 

i 

END  DO  LOOP 

0260 

DIR=0 

i 

• 

INITIALIZE  DIRECTION 

0261 

DO  33  1=1 IFIX( BLNG) , I IFIX ( BLNG) +10,5 

i 

• 

LABEL  LONGITUDE 

0262 

IF  (I.GT.0)  DIR= ' E ' 

i 

• 

EAST  FOR  POSITIVE 

0263 

IF  (I.LT.0)  DIR= ' W ' 

i 

• 

WEST  FOR  NEGATIVE 

0264 

IF  (I.EQ.0)  DIR=0 

i 

• 

GREENWICH  MEAN  LINE  FOR 

0265 

CALL  MOVE( IX(50*(I -BLNG) -14 ) , IY( USRTAN ( BLAT ) ) -14 )  !  MOVE  PEN 

j266 

ENCODE (4,10001,1 STR )  IABS(I),DIR 

i 

ENCODE  STRING 

0267 

CALL  TEXT (4, I STR) 

i 

• 

LABEL  AT  BOTTOM 

0268 

CALL  MOVE( IX( 50* ( I -BLNG) -14 ) , I Y( USRTAN ( ( BLAT+10 ) ) ) +14 ) !  MOVE 

0269 

ENCODE(4, 10001, ISTR)  IABS(l),DIR 

i 

• 

ENCODE  TEXT 

0270 

CALL  TEXT (4, ISTR) 

i 

* 

LABEL  AT  TOP 

0271 

33 

CONTINUE 

; 

END  DO  LOOP 

0272 

0273 

1 - 

- TITLE  THE 

PICTURE  WITH  THE  OCEAN  ARE 

0274 

CALL  MOVE( 20,378) 

; 

MOVE  PEN 

0275 

CALL  TEXT( 20 , TITLE ( 1 ) ) 

| 

OCEAN  AREA  NAME 

0276 

CALL  MOVE (39,336) 

i 

MOVE  PEN 

0277 

TYPE  * , ' ! STR  /60  NMI  Range  List/' 

| 

STEAMING  RADIUS 

0278 

CALL  MOVE (23,322) 

i 

MOVE  PEN 

0279 

TYPE  *,'!STR  /(within  dotted  circle)/' 

j 

STEAMING  RADIUS 

0280 

0281 

IF  (DTYPE.EQ. 3 )  THEN 

1 

IF  BOTTOM  DATA 

0282 

CALL  MOVE (28,308) 

j 

MOVE  PEN 

0283 

TYPE  * , ' ! STR  /500  Fathom  Intervals/' 

! DEPTH  CONTOUR  INTERVALS 

0284 

END  IF 

t 

END  IF  BLOCK 

0285 

IF  (DTYPE.GT.2)  GO  TO  999 

! 

IF  NON- POLYGON  DATA,  RE 

0286 

0287 

■ 

A  riTAom  .  . . 

• 

i’ll 

ru.\LJ  n.  j. 

0288 

X=48 

i 

X  COORDINATE 

0289 

Y=308 

| 

Y  COORDINATE 

0290 

CALL  MOVE ( X , Y ) 

1 

MOVE  PEN 

0291 

TYPE  * , ' ! STR  /Code  Distance/' 

f 

WRITE  TITLE 

°292 

Y=Y-14 

i 

RESET  Y  COORD 

£93 

CALL  MOVE ( X , Y ) 

1 

MOVE  PEN 

0294 

TYPE  *,  '  !  STR  / -  - /’ 

i 

UNDERLINE  TITLE 

0295 

Y=Y-14 

I 

RESET  Y  COORD 

0296 

DO  48  I=IIFIX(S(0) )+l,IIFIX(S(0)+S(lIFIX(S(0) ) ) )  !  DISPLAY  OPTIO 

0297 

J=IIFIX(S( IIFIX(S( I) ) ) ) 

!  SET  INDEX  CODE 

0298 

K=IIFIX{S(I+IIFIX(S(IIFIX(S(0) ) ) )))  !  SET  DISTANCE 

0299 

IF  (K.GT. IIFIX(SRAD) )  GOTO  49 

!  DISTANGE  >  RADIUS 

0300 

IF  (J.LT.0)  C=STAR 

!  PROMPT  FOR  LAND 

0301 

IF  (J.LT.0)  LAND= . TRUE . 

!  DISPLAY  LAND  TEXT  FLAG 

0302 

IF  (J.EQ.0)  C=HYP 

!  PROMPT  FOR  UNMARKED  WAT 

0303 

IF  (J.EQ.0)  UNMARK= . TRUE . 

!  UNMARKED  WATER  FLAG 

0304 

IF  (J.GT.O)  ENCODE(3, 10003, C)  J 

I  SET  DISTANCE  PROMPT 

0305 

IF  (K.LT.O)  THEN 

!  DISTANCE  IS  NEGATIVE 

0306 

DO  42  L=1 , 5 

!  SET  INTERIOR  PROMPT 

0307 

TXT ( L ) = I NTER ( L ) 

!  WRITE  ’INTER' 

0308 

42 

CONTINUE 

!  END  DO  LOOP 

0309 

END  IF 

!  END  IF  BLOCK 

0310 

IF  (K.EQ.O)  THEN 

!  DISTANCE  IS  ZERO 

0311 

DO  44  L=1 , 5 

!  SET  BOUND  PROMPT 

0312 

TXT ( L ) =  BOUND ( L ) 

!  WRITE  'BOUND' 

0313 

44 

CONTINUE 

!  END  DO  LOOP 

0314 

END  IF^ 

!  END  IF  BLOCK 

0315 

IF  (K.GT.0)  ENCODE (5,46, TXT )  K 

!  SET  DISTANCE  PROMPT 

0316 

CALL  MOVE ( X , Y ) 

!  MOVE  PEN 

0317 

CALL  TEXT (3,C) 

!  DISPLAY  CODE 

0318 

CALL  MOVE ( X+57 ,  Y ) 

!  MOVE  PEN 

0319 

CALL  TEXT (5, TXT) 

!  DISPLAY  DISTANCE  TEXT 

0320 

Y=Y-14 

!  RESET  Y  COORD 

0321 

48 

CONTINUE 

!  END  DO  LOOP 

0322 

49 

Y=Y-42 

!  SET  Y  COORDINATE 

0323 

X=X-32 

!  SET  X  COORDINATE 

^324 

CALL  MOVE ( X , Y ) 

!  MOVE  PEN 

4325 

IF  (LAND)  TYPE  * ,  '  !  STR  /"*"  --  Land/ 

'  !  LAND  FLAG  SET 

0326 

IF  (LAND  .AND.  UNMARK)  CALL  MOVE(X,Y- 

14 ) !  MOVE  PEN 

0327 

IF  (UNMARK)  TYPE  * , ' ! STR  —  Undefined  Water/'  !  UNMARK 

0328 

999 

RETURN 

!  RETURN  TO  CALLING  ROUT I 

0329 

0330 

f 

_ A  T1  CP  A  fP'E,\ifI?\TrPC 

T  Utvnn  I  oinl  EjjyiiliJN  io 

0331 

23 

FORMAT ( I <LEN>) 

0332 

46 

FORMAT (15) 

0333 

10001 

FORMAT ( I 3 , Al ) 

0334 

10002 

FORMAT ( I 2 , Al ) 

0335 

10003 

FORMAT (13) 

0336 

END 

C-1H.C 


0001  INTEGER* 2  FUNCTION  I NDX ( LAT , LNG , DTYPE ) 

0002  ! 

JO 03  !  PROLOGUE: 

0004  !  MODULE  NAME:  I NDX 

0005  !  AUTHOR:  E.  PETR IDES  &  P.  FRAGEORGI A  OF  SYSCON,  INC 

0006  !  RECODED:  W.  WACHTER,  CODE  3333,  NUSC/NLL 

0007  !  DATE:  1982  &  6/84  (FORTRAN  77) 

0008  !  FUNCTION:  THIS  FUNCTION  IS  DESIGNED  TO  CALCULATE  THE  INDEX  OF 

0009  !  THE  POINTER  IN  RECNDX  BY  USING  THE  LATITUDE  AND  LONGITUDE 

0010  !  OF  THE  FIVE  DEGREE  SQUARE  OF  THE  DATA  TYPE. 

0011  !  INPUTS:  VARIABLES  NEEDED  TO  CALCULATE  INDEX 

0012  !  OUTPUTS:  THE  INDEX  OF  THE  POINTER  IN  RECNDX 

0013  !  MODULES  CALLED:  NONE 

0014  !  CALLED  BY:  MAP 

0015  ! 

0016  INCLUDE  'CL. INC' 

0017  1  !  - CL.  INC - 

0018  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0019  1  !  - -  -  -  - 

0020  1  !  LATMAX  MAXIMUM  LATIITUDE  INTEGER* 2 

JD021  1  !  L  ATM  IN  MINIMUM  LATIITUDE  INTEGER*  2 

0022  1  !  LNGMAX  MAXIMUM  LONGITUDE  INTEGER* 2 

0023  1  !  LNGMIN  MINIMUM  LONGITUDE  INTEGER* 2 

0024  1  ! 

0025  1  INTEGER* 2  LATMIN, LATMAX , LNGMIN , LNGMAX 

0026  1 

0027  1  COMMON  /CL/  LATMIN , LATMAX , LNGMIN , LNGMAX 

0028  1  ! - END  CL.  INC - 

0029  1 

JO  30  ! 

0031  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0032  ! -  -  -  - 

0033  !  DTYPE  CURRENT  DATA  TYPE  INTEGER* 2 

0034  !  I LAT  5  DEG  LAT  OFFSET  FOR  OWN  SHIP  INTEGER* 2 

0035  !  I LNG  5  DEG  LNG  OFFSET  FOR  OWN  SHIP  INTEGER *2 

0036  !  LAT  BASE  LAT  OF  THE  5  DEGREE  SQUARE  INTEGER* 2 

0037  !  LNG  BASE  LNG  OF  THE  5  DEGREE  SQUARE  INTEGER* 2 

0038  ! 

0039  !  ***  VARIABLES  NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMONS  *** 

0040 

0041  INTEGER* 2  DTYPE , I LAT , I LNG , LAT , LNG 

0042 

0043  ILAT=LAT-LATMIN/5  !  5  DEG  LAT  OFFSET  FOR  OWN  SHIP  POSITION 

0044  I LNG=LNG-LNGMIN/5  !  5  DEG  LNG  OFFSET  FOR  OWN  SHIP  POSITION 

0045  I NDX  = ( ( DTYPE- 1 ) * ( LATMAX -LATMIN)/5  +  I LAT ) * ( LNGMAX - LNGM IN)/5  +  ILNG+l 

0046  *  INDEX  FOR  CURRENT  TYPE  OF  5  DEG  SQUARE 

0047  RETURN  !  RETURN  TO  CALLING  ROUTINE 

0048  END  !  END  SUBROUTINE 


t 


0001 

«002 

<5003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 

0011 

0012 

0013 

0014 

0015 


0027 
0028 
<1029 
J  030 
0031 
0032 
0033 
0034 
0035 


0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 

0055 

yp56 

S057 

0058 

0059 


SUBROUTINE  INITT ( LNSMON ) 

PROLOGUE : 

MODULE  NAME:  INITT 

AUTHOR:  J.  CASCIO,  W.  WACHTER ( FORTRAN  77),  NUSC/NL,  CODE  3333 

DATE:  1981  &  9/84  (FORTRAN  77) 

FUNCTION:  INITIALIZATION  ROUTINE  FOR  THE  TEKTRONIX  4025  TERMINAL 

INPUTS:  NUMBER  OF  LINES  FOR  TERMINAL 

OUTPUTS:  INITIALIZED  TERMINAL 

MODULES  CALLED:  NONE 

CALLED  BY:  PLT25,  SVPGRF,  TIC 

NOTE:  THE  TERMINAL  ALWAYS  KEEPS  A  BLANK  LINE  BETWEEN  THE  MONITOR  AND 
THE  WORK  SPACE. 


UU  ID 

0017 

J. 

1 

I 

VARBL 

SIZE 

0018 

1 

i 

— 

0019 

1 

j 

I CL  IP 

(4) 

0020 

1 

j 

ISCLIP 

0021 

1 

i 

LENX 

0022 

1 

i 

LENY 

0023 

1 

; 

MAXX 

0024 

1 

i 

MAXY 

0025 

1 

1 

MINX 

0026 

1 

i 

• 

MINY 

INCLUDE  'SCREEN. INC' 


PURPOSE 


-SCREEN- 


CLIP  BOUNDARIES 
CLIPPING  FLAG 

LENGTH  OF  X  GRAPHICS  BOUNDARY 
X  GRAPHICS  BOUNDARY 
GRAPHICS  BOUNDARY 
GRAPHICS  BOUNDARY 
GRAPHICS  BOUNDARY 
GRAPHICS  BOUNDARY 


LENGTH  OF 
MAXIMUM  X 
MAXIMUM  Y 
MINIMUM  X 
MINIMUM  Y 


TYPE 

INTEGER*2 
INTEGER *2 
INTEGER*2 
INTEGER*2 
INTEGER*2 
INTEGER* 2 
INTEGER *2 
INTEGER* 2 


RANGE 


TRUE  FALSE 


1 

1 

1 

1 

1 

1 

1 


INTEGER* 2  I CL I P , LENX , LENY 
INTEGER* 2  MAXX , MAXY , M I NX , M I NY 
INTEGER*2  ISCLIP 

COMMON  /SCREEN/MI NX, MAXX, MI NY, MAXY, LENX, LENY, ICLIP(4) , ISCLIP 

- SCREEN  END - 

INCLUDE  'USER. INC' 

- USER - 


0036 

0037 

1 

1 

j 

j 

VARBL  SIZE 

PURPOSE 

TYPE 

0038 

1 

i 

• 

XFCTR 

FACTOR  FOR  X  AXIS  LENGTH 

RATIO 

REAL *4 

0039 

1 

i 

XLEN 

LENGTH  OF 

X  AXIS 

REAL *4 

0040 

1 

j 

YFCTR 

FACTOR  FOR  Y  AXIS  LENGTH 

RATIO 

REAL *4 

0041 

1 

i 

YLEN 

LENGTH  OF 

Y  AXIS 

REAL *4 

0042 

1 

i 

• 

XMAX 

MAXIMUM  X 

COORDINATE 

REAL *4 

0043 

1 

j 

XMIN 

MINIMUM  X 

COORDINATE 

REAL *4 

0044 

1 

i 

• 

YMAX 

MAXIMUM  Y 

COORDINATE 

REAL *4 

0045 

0046 

1 

1 

! 

• 

YMIN 

MINIMUM  Y 

COORDINATE 

REAL *4 

RANGE 


1 

1 

1 

1 


REAL* 4  XMIN , XMAX , YMIN, YMAX , XLEN , YLEN, XFCTR , YFCTR 

COMMON  /USER/XM I N , XMAX , YM I N , YMAX , XLEN , YLEN , XFCTR , YFCTR 
- USER  END - 


VARBL  SIZE  PURPOSE 


LNSGRF  #  OF  LINES  IN  GRAPGHIC  AREA 

LNSMON  #  OF  LINES  USED  BY  THE  TERMINAL 


TYPE 

INTEGER*2 
INTEGER *2 


RANGE 


2  TO  10 


***  VARIABLES  NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMONS  *** 
INTEGER* 2  LNSGRF , LNSMON 


0060 
0061 
2  062 
0063 
0064 
0065 
0066 
0067 
0068 
0069 
0070 
0071 
0072 
0073 
0074 
0075 
0076 
0077 
0078 
0079 
0080 
0081 
0082 
0083 
0084 
0085 


DATA  MINX,MINY, ICLIP(l) , ICLIP(3) ,MAXX,LENX, ICLIP( 2 ) /4*0 , 3*639/ 
DATA  ISCLIP/. FALSE . / 


IF  (LNSMON.LT. 2)  LNSMON=2 
IF  (LNSMON.GT.IO)  LNSMON=10 
LNSGRF=33-LNSMON 
WRITE (5,2)  LNSMON , LNSGRF 


ESTABLISH  WORKSPACE - 

!  MINIMUM  #  OF  LINES  USED  BY  MON 
!  MAXIMUM  #  OF  LINES  USED  BY  MON 
!  #  OF  LINES  IN  GRAPHICS  WORKSPA 
!  DISPLAY  #  OF  LINES 


MAXY= 14* LNSGRF- 1 
LENY=MAXY 
ICLIP ( 4 ) =MAXY 
XMIN=FLOATI (MINX) 

XMAX=  FLOAT I (MAXX) 
YMIN=FLOATI (MINY) 

YMAX=  FLOAT I (MAXY) 
XLEN=XMAX-XMIN 
YLEN=YMAX-YMIN 
XFCTR=XLEN/FLOAT I ( LENX ) 
YFCTR=YLEN/ FLOAT I ( LENY ) 
RETURN 


SCREEN  LIMITS  FOR  THE  WORKSPACE - 
!  MAXIMUM  Y  IS  433,  MINIMUM  IS  0 
!  LENGTH  OF  Y 
!  SET  FOR  CLIPPING  AREA 
!  MINIMUM  X 
!  MAXIMUM  X 
!  MINIMUM  Y 
!  MAXIMUM  Y 
!  LENGTH  OF  X 
!  LENGTH  OF  Y 
!  X  FACTOR 
!  Y  FACTOR 

1  RETURN  TO  CALLING  ROUTINE 


! - FORMAT  STATEMENT - r - 

2  FORMAT ( '  ! MON  '  , 12 , '  ! GRA  1 , ' , 12  ) 

END 


C-at.a 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 

0011 

0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 

0021 

0022 

0023 

0024 

0025 

0026 

0027 

0028 

"5029 

<5030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 

0055 

1056 

<3057 

0058 

0059 


SUBROUTINE  INSERT (N, Z ,C , Z0 , NU) 

PROLOGUE : 

MODULE  NAME:  INSERT 

AUTHOR:  G.  BROWN  &  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  1974  &  10/83  (FORTRAN  77) 

FUNCTION:  SUBROUTINE  INSERT  ALLOWS  THE  OPERATOR  TO  INSERT 
TARGET  DEPTH  POINT  INTO  SOUND  SPPED  PROFILE 
INPUTS:  NEW  POINTS  TO  BE  ADDED 
OUTPUTS:  UPDATED  ARRAY  FOR  C  AND  Z 
MODULES  CALLED:  NONE 

CALLED  BY:  ACT26 , ASIS, DIMUS , ENVIRN, FORCST , NOCONV , OTHERS , PBB18 , 
PBB19 , PSSV , RAXIN , SETUP , S IMCZ , SVPGRF , XBT 


ALGORITHMS  USED: 

DEPTH  POINT:  Z(N+1)  =  Z0 

VELOCITY  POINT:  C(N)-C(N-1) 

C(N+1)  =  C(N-l)  + - *  (Z0  -  Z(N-l) 

Z(N)-Z(N-1) 


VELOCITY  POINT  INTERPOLATION: 

C(J+1)  -  C(J-l) 

C(J)  =  C(J-l)  + -  *  (Z0  -  Z(J-l) 

Z(J+1)  -  Z(J-l) 


VARBL  SIZE  PURPOSE  TYPE  RANGE 


c 

(1) 

VELOCITY 

REAL *4 

I 

COUNTER 

INTEGER* 2 

J 

COUNTER 

INTEGER* 2 

N 

#  OF  DEPTH /VELOCITY  PAIRS 

INTEGER *2 

NU 

SVP  INDEX 

INTEGER* 2 

NUP 

UPPER  LIMIT  INDEX  OF  TABLE 

INTEGER* 2 

Z 

(1) 

DEPTH 

REAL *4 

ZL 

LOWER  RANGE  OF  INPUT  DEPTH 

REAL *4 

ZU 

UPPER  RANGE  OF  INPUT  DEPTH 

REAL *4 

zo 

SPECIFIED  DEPTH  VALUE 

REAL *4 

INTEGER* 2  I,J,N,NU,NUP 
REAL *4  C , Z , ZL , ZU , Z0 
DIMENSION  Z(l) ,C(1) 


NU=1 

IF  (Z0.LT.0.9)  GO  TO  999 
IF  ( Z0 .GT . Z (N) +0 . 9 )  THEN 
Z ( N+ 1 ) =Z0 

C ( N+l ) =C(N-1 ) + (C ( N) -C ( N-l ) ) 

N=N+1 

NU=N 

GO  TO  999 
ELSE 
NUP=N 
ZL=Z0-0 .9 
ZU=Z0+0 . 9 


!  INITIALIZE 
!  INVALID  DEPTH 
!  INPUT  DEPTH  >  LAST  MAX 
!  ADD  EXTRA  TABLE  PT  AT  N+l 
Z(N) -Z(N-l) )*(Z0-Z(N-1) ) 

!  INCREASE  #  OF  PAIRS  BY  1 
!  RETURN  NEW  #  OF  PAIRS  IN  NU 
!  RETURN  TO  CALLING  ROUTINE 
!  INPUT  DEPTH  <  CURRENT  MAX 
!  #  OF  PAIRS 

!  TOLERANCE  LIMIT  ABOUT  Z0 
!  TOLERANCE  LIMIT  ABOUT  Z0 


C--2  7,  I 


0060 

DO  100  J=2 ,NUP 

; 

FIND  WHERE  TO  ADD  NEW  PAIR 

0061 

IF  (Z(J).GE.ZL)  THEN 

j 

NEW  Z  ABOVE  LOWER  RANGE 

J062 

NU=J 

i 

SET  #  OF  PAIRS 

0063 

IF  (Z(J).LE.ZU)  GO 

TO  999  ! 

TOO  CLOSE  TO  EXISTING  POINT 

0064 

DO  50  I=NUP, J, -1 

i 

PREPARE  TO  INSERT  NEW  POINT 

0065 

Z(I+1)=Z(I) 

i 

MOVE  ELEMENTS  UP  1 

0066 

C(I+1)=C(I) 

i 

UNTIL  REACH  PLACE 

0067 

50 

CONTINUE 

1 

TO  INSERT  NEW  PAIR 

0068 

Z(J)=Z0 

i 

NEW  PAIR  INSERTED  AT  J 

0069 

C(J)=C(J-1)+(C(J+1) 

-C(J-l) )/(Z(J+l)-Z(J-l) )*(Z0-Z( J-l) ) 

0070 

N=N+1 

[ 

INCREASE  #  OF  PAIRS  BY  1 

0071 

GO  TO  999 

! 

RETURN  TO  CALLING  ROUTINE 

0072 

END  IF 

f 

END  IF  BLOCK 

0073 

100 

CONTINUE 

I 

END  DO  LOOP 

0074 

999 

RETURN 

J 

RETURN  TO  CALLING  ROUTINE 

0075 

END  IF 

1 

END  IF  BLOCK 

0076 

END 

J 

END  SUBROUTINE 

COMMAND  QUALIFIERS 

FORTRAN  /CHECK* ALL/LI ST/SHOW* ( INCLUDE, NOMAP)  [LAFLEUR] INSERT . F7 7 

/ CHECK = ( BOUNDS , OVERFLOW , UNDERFLOW ) 

/DEBUG* ( NOSYMBOLS , TRACEBACK ) 

/STANDARD* (NOSYNTAX , NOSOURCE_FORM ) 

/SHOW* ( NOPREPROCESSOR , I NCLUDE , NOMAP ) 

/F77  /NOG  FLOATING  /I4  /OPTIMIZE  /WARNINGS  /NOD  LINES  /NOCROSS  REFERENCE 


COMPILATION  STATISTICS 


Run  Time: 
Elapsed  Time: 
Page  Faults: 
Dynamic  Memory: 


1.29  seconds 
1.68  seconds 
335 

113  pages 


C-2  9,5. 


0001 
0002 
1)003 
0004 
0005 
0006 
0007 
0008 
0009 
0010 
0011 
0012 
0013 
0014 
0015 
0016 
0017 
0018 
0019 
0020 
0021 
0022 
0023 
0024 
0025 
0026 
0027 
0028 
0029 
y  0  3  0 
0031 
0032 
0033 


SUBROUT I NE  I NUMBR ( I V AL , LENGTH ) 


PROLOGUE: 

MODULE  NAME:  I NUMBR 

AUTHOR:  J.  CASCIO,  W.  WACHTER( FORTRAN  77),  NUSC/NL,  CODE  3333 
DATE:  1981  &  9/84  (FORTRAN  77) 

FUNCTION:  CONVERT  INTEGER*2  VARIABLE  INTO  ASCII 

INPUTS:  INTEGER*2  VALUE 

OUTPUTS:  ASCII  EQUIVALENT 

MODULES  CALLED:  TEXT 

CALLED  BY:  SVPGRF 

VARBL  SIZE  PURPOSE  TYPE  RANGE 


IVAL  VARIABLE  TO  BE  CONVERTED  TO  ASCII  CODE  INTEGER*2 
J  LOOP  COUNTER  INTEGER*2 
LENGTH  NUMBER  OF  DIGITS  IN  IVAL  INTEGER* 2 
STRING  (10)  ASCII  CONVERSION  OF  IVAL  BYTE 

INTEGER*2  IVAL , J , LENGTH 
BYTE  STRING ( 10 ) 


DO  50  J=l,10 
STRING (J ) =0 
50  CONTINUE 

I F ( LENGTH . LE . 0 . OR . LENGTH . GT . 1 0 
ENCODE (LENGTH, 51, STRING)  IVAL 
CALL  TEXT (LENGTH, STRING) 

RETURN 


!  DO  FOR  ALL  ARRAY  ELE 
!  ZERO  OUT  ARRAY 
!  END  DO  LOOP 

LENGTH=10  !  MAXIMUM  LENGTH  IS  10 
!  CONVERT  TO  ASCII 
!  ASCII  TO  BE  OUTPUTED 
!  RETURN  TO  CALLING  RO 


51 


FORMAT  STATEMENT- 
FORMAT  (  I  <LENGTH>) 
END 


c  -a*.  I 


0001 
0002 
P  0  0  3 
0004 
0005 
0006 
0007 
0008 
0009 
0010 
0011 
0012 
0013 
0014 
0015 
0016 
0017 
0018 
0019 
0020 
0021 
0022 


0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 

0055 

0056 

)057 

0058 

0059 


1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 


SUBROUTINE  KEYPCH ( INSSP , NBT , MAPFLG ) 

PROLOGUE : 

MODULE  NAME:  KEYPCH 

AUTHOR:  S.  LAFLEUR  &  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  1982  &  12/83  (FORTRAN  77) 

FUNCTION:  SUBROUTINE  KEYPCH  ALLOWS  THE  OPERATOR  TO  INPUT 
SPECIFIC  PROFILES. 

INPUTS:  PARAMETERS  PASSED  IN.  VARIABLES  IN  COMMONS. 
OUTPUTS:  CRT  PROMPTING  MESSAGES  TO  OPERATOR. 

MODULES  CALLED:  BT , ICLR , IDATE , KSCAT , LATLNG , SSP , SVPRO 
CALLED  BY:  ENV I RN , FORCST 

NOTE:  IF  CALLED  BY  ENVIRN  (IF  IANS  =  1) 

AUTOMATED  HISTORICAL  SSP  MERGED  W/  MANUAL  BT 
AUTOMATED  HISTORICAL  SSP 
NOTE:  IF  CALLED  BY  FORCST  (IF  IANS  =  2) 

AUTOMATED  HISTORICAL  SSP 
MANUAL  HISTORICAL  SSP 

MANUAL  HISTORICAL  SSP  MERGED  WITH  MANUAL  BT 
OPERATOR  WILL  KEYPUNCH  SPECIFIC  PROFILE 


(IF 

INSSP 

= 

1) 

( IF 

INSSP 

= 

2) 

(IF 

INSSP 

ss 

2) 

( IF 

INSSP 

= 

3) 

( IF 

INSSP 

- 

4) 

( IF 

INSSP 

= 

5  ) 

0023 

0024 

0025 

1 

1 

INCLUDE 

'DTV. INC' 

—  _  _  _ nTU _ _ 

i 

• 

VARBL 

SIZE 

^  ^  U  1  V  —  —  —  - 

PURPOSE 

TYPE 

0026 

1 

; 

- - 

— 

0027 

1 

i 

• 

D 

(25) 

DEPTH 

REAL*4 

0028 

1 

i 

DD 

(25) 

DEPTH 

REAL *4 

D029 

1 

i 

• 

NNBT 

NUMBER  OF  BATHETHERMAL 

INTEGER* 2 

J030 

1 

i 

T 

(25) 

TEMPERATURE 

REAL* 4 

0031 

1 

i 

TT 

(25) 

TEMPERATURE 

REAL *4 

0032 

1 

i 

• 

VEL 

(25) 

VELOCITY 

REAL* 4 

RANGE 


INTEGER* 2  NNBT 
REAL  *  4  D , DD , T , TT , VEL 


COMMON  /DTV/ 


VARBL 

SIZE 

BIO 

(2) 

DLYR 

MGS 

D( 25 ) ,T( 25 ) , VEL( 25) , DD( 25 ) ,TT ( 25 ) , NNBT 

- END  DTV - 

INCLUDE  ' ENVN . INC ' 

- ENVN - 

PURPOSE  TYPE 


BIOLOGICAL  BACK  SCATTERING  REAL *4 
LAYER  DEPTH  REAL *4 

MGS  PROVINCE  INTEGER* 2 


REAL  *  4  BIO , DLYR 

INTEGER* 2  MGS 
DATA  BIO/-57 . ,-47./ 

COMMON  /ENVN/  BIO( 2 ) , DLYR , MGS 

- END  ENVN— 

--GRF - 


RANGE 

-57.  &  -47. 


INCLUDE  ' GRF .  INC ' 
VARBL  SIZE  PURPOSE 


DBT 

IANS 


(25) 


DEPTH  OF  DEPTH/VEL  PAIR 
PREDICTION  TYPE 


TYPE 

REAL *4 
INTEGER*2 


RANGE 


-2  TO  +2 


C-  21.  I 


0060  1  !  ILYR  INDEX  FOR  LAYER  DEPTH  INTEGER* 2 

0061  1  !  INBT  OPERATOR  ENTERED  #  OF  BT  POINTS  INTEGER* 2 

062  1  !  ISVP  LATEST  OR  HISTORICAL  BT  FLAG  INTEGER *2  1  OR  2 

0063  1  !  12000  SVP  INDEX  FOR  2000  FT  DEPTH  INTEGER* 2 

0064  1  !  VBT  (25)  VELOCITY  FOR  DEPTH  PAIR  REAL*4  REAL *4 

0065  1 

0066  1  REAL *4  DBT, VBT 

0067  1  INTEGER*2  I ANS , I LYR , INBT , ISVP ,  1 2000 

0068  1 

0069  1  COMMON  /GRF/  IANS, ISVP, ILYR, 12000 , INBT , DBT( 2 5 ) , VBT ( 25 ) 

0070  1 

0071  1  ! - END  GRF - 

0072  INCLUDE  'LOC.INC' 

0073  1  ! - LOC - 

0074  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0075  1  ! -  -  -  - 

0076  1  !  INDX  SSP  INDEX  INTEGER*2 

0077  1  !  LAT  (4)  LATITUDE  INTEGER *2 

0078  1  !  LONG  (4)  LONGITUDE  INTEGER* 2 

0079  1  !  NMAREA  (20)  AREA  OCEAN  NAME  BYTE 

0080  1  !  NOC  NUMBER  OF  OCEAN  INTEGER* 2 

0081  1  !  RCZ  RANGE  TO  CONVERG.  ZONE  REAL *4 

0082  1 

0083  1  REAL  *4  RCZ 

0084  1  INTEGER* 2  INDX , LAT , LONG , NOC 

0085  1  BYTE  NMAREA (20) 

0086  1 

0087  1  COMMON  /LOC/  LAT(4) ,LONG(4) , NOC, INDX, RCZ, NMAREA 

0088  1 

JO  8  9  1  ! - END  LOC - 

0090  INCLUDE  'SVP. INC' 

0091  1  ! - SVP - 

0092  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0093  1  ! -  -  -  - 

0094  1  !  BDF  BOTTOM  DEPTH  IN  FATHOMS  REAL* 4 

0095  1  !  BIOP  BIOLOGICAL  BACK  SCATTERING  COEF  REAL* 4 

0096  1  !  BTDATE  (9)  DATE  OF  LAST  BT  INPUT  BYTE 

0097  1  !  BTTIME  (8)  TIME  OF  LAST  BT  INPUT  BYTE 

0098  1  !  C  (50)  VELOCITY  (PAIRED  WITH  Z  FOR  SVP)  REAL *4 

0099  1  !  CC  (50)  VELOCITY  (PAIRED  WITH  ZZ  FOR  SVP)REAL*4 

0100  1  !  CS  SOUND  VELOCITY  AT  SURFACE  REAL *4 

0101  1  !  DEG  TEMPERATURE  (DEG)  REAL *4  57.2957795 

0102  1  !  EL  LAYER  DEPTH  DATA 

0103  1  !  F  FREQUENCY  REAL *4 

0104  1  !  GRDS  GRIDS  REAL*4  0.0164 

0105  1  !  ITO  MINIMAL  2-WAY  TRAVEL  TIME  INTEGER*2 

0106  1  !  MGSOP  MGS  PROVINCE  NUMBER  INTEGER* 2 

0107  1  !  N  #  OF  DEPTH/VELOCITY  PAIRS  INTEGER* 2 

0108  1  !  NN  #  OF  DEPTH/VELOCITY  PAIRS  INTEGER* 2 

0109  1  !  PI  MATHEMATICAL  CONSTANT  PI  REAL *4  3.1415927 

0110  1  !  SNDATE  (9)  DATE  SYS  PARMS  LAST  UPDATED  BYTE 

0111  1  !  SNTIME  (8)  TIME  SYS  PARMS  LAST  UPDTAED  BYTE 

0112  1  !  SYDATE  (9)  CURRENT  DATE  READ  FROM  SYSTEM  BYTE 

0113  1  !  SYTIME  (8)  CURRENT  TIME  READ  FROM  SYSTEM  BYTE 

0114  1  !  TMP  TEMPERATURE  REAL *4 

0115  1  !  UMKZ  BOTTOM  BACK  SCATTERING  COEF.  REAL*4  -28.0 

1.16  1  !  WS  WIND  SPEED  REAL  *  4 

0117  1  !  Z  (50)  DEPTH  OF  POINT  OF  SOUND  SPEED  REAL *4 

0118  1  !  ZZ  (50)  DEPTH  OF  POINT  OF  SOUND  SPEED  REAL *4 


C-  2.*!.  7. 


0119 

0120 

>121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

)l48 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 

0161 

0162 

0163 

0164 

0165 

0166 

0167 

0168 

0169 

0170 

0171 

0172 

0173 


0174 

)l75 

0176 


0177 


1 

1  INTEGER* 2  ITO , MGSOP , N , NN 

1  REAL *4  BDF , B I OP , C { 5  0 ) , CC (50) ,  CS , DEG , EL , F , GRDS 

1  REAL *4  PI , TMP , UMKZ , WS ,Z(50) ,ZZ(50) 

1  BYTE  SYDATE ( 9 ) , SYTIME ( 8  )  , BTDATE ( 9 ) , BTTIME ( 8 ) 

1  BYTE  SNDATE ( 9 )  , SNTIME( 8 ) 

1  DATA  PI,DEG,GRDS/3 .1415927,57.2957795,0.0164/ 

1  DATA  UMKZ/- 2 8./ 

1 

1  COMMON  /SVP/  F, N, Z,C, EL, MGSOP, BDF, WS,CS, TMP, BIOP, 

1  1  UMKZ, PI , DEG, GRDS, ITO, ZZ,CC,NN, 

1  2  SYDATE, SYTIME, BTDATE, BTTIME, SNDATE, SNTIME 

1  j - SVP -END - 

INCLUDE  ' SVP 1. INC' 

1  I - SVP1 - 

1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

1  ! -  -  -  - 

1  !  BUFFER  (224)  HISTORICAL  DATA  FILE  BUFFER  REAL *4 

1  !  DS  (30)  HISTORICAL  DEPTH  REAL *4 

1  !  J20  #  OF  DEEP  OCEAN  DEPTH/VEL  PAIRS  INTEGER*2 

1  !  NS  TOTAL  #  OF  PAIRS  IN  HISTORICAL  _  INTEGER* 2 

1  !  NSN  MONTH  NUMBER  (1= JAN., ETC)  INTEGER* 2  1  TO  12 

1  !  SLNTY  SALINITY  REAL *4 

1  !  VS  (30)  HISTORICAL  VELOCITY  REAL*4 

1 

1  REAL *4  BUFFER, DS, SLNTY, VS 

1  INTEGER* 2  J20,NSN,NS 

1 

1  COMMON  /SVP1/  J20 ,BUFFER(224) , NSN, SLNTY, DS(30) ,VS(30) , NS 

1  ! - END  SVP1 - 

!  VARBL  SIZE  PURPOSE  TYPE  RANGE 


I  COUNTER  INTEGER* 2 

I BEG  I MONTH  ARRAY  POINTER  INTEGER* 2 

I END  I MONTH  ARRAY  POINTER  INTEGER* 2 

IDD  CURRENT  DAY  INTEGER* 4 

INSSP  SSP  SELECTED  INTEGER* 2 

IMONTH  (36)  MONTH  NAMES  BYTE 

IMM  CURRENT  MONTH  INTEGER* 4 

IYY  CURRENT  YEAR  INTEGER* 4 

MAPFLG  COUNTER  INTEGER*2 

NANS  OPERATOR  RESPONDSE  INTEGER *2 

NBT  NUMBER  OF  BT  INTEGER*2 


***  VARIABLES  NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMONS  *** 

INTEGER*2  I , I BEG , I END 
INTEGER* 2  INSSP , MAPFLG , NANS , NBT 
INTEGER* 4  IMM, IDD, IYY 
BYTE  IMONTH (36) 


DATA 

IMONTH/ ' J ' , 

' A' , ' N' 

,  '  F ' 

, 'E'  , '3'  , 

'M' 

, ' A’  ,  ’R’  , 

1 

'A'  , 

’P' , 'R' 

,  ’M’ 

, ' A' , ' Y' , 

'  J' 

, 'U' , 'N' , 

2 

' J '  , 

'U' , 'L' 

,  ’  A' 

, 'U' , 'G' , 

'  S' 

, 'E' , 'P' , 

3 

'O'  , 

1 C' , 1 T ' 

,  'N' 

, 'O' , 'V' , 

’  D' 

, 'E' , 'C'/ 

CALL 

ICLR 

| 

CLEAR  SCREEN 

I F ( INSSP.EQ.5)  THEN  !  KEYPUNCH  SSP  SELECTED 


C-2°J,  1 


0178 

WRITE( 5,6050) 

| 

SALINITY  PROMPT 

0179 

READ (5,1370)  SLNTY 

; 

INPUTS  SALINITY 

)180 

CALL  ICLR 

» 

CLEAR  SCREEN 

0181 

WRITE ( 5 , 3006) 

| 

NAME  OCEAN  AREA  PROMPT 

0182 

READ (5, 3007)  NMAREA 

i 

AREA-NAME  FOR  LABELING 

0183 

CALL  KSCAT (BIO(l) , B I 0 ( 2 ) , UMKZ ) 

i 

OPERATOR  SCAT .  COEFF . ' S 

0184 

END  IF 

; 

END  IF  BLOCK 

0185 

0186 

70 

IF ( IANS.NE.2)  THEN 

t 

FORECASTING  SELECTED 

0187 

CALL  I DATE ( IMM, IDD, IYY) 

! 

GET  CURRENT  MONTH 

0188 

NSN= IMM 

0189 

IBEG=NSN*3-2 

j 

ARRAY  START  POINTER 

0190 

I END= IBEG+2 

i 

ARRAY  END  POINTER 

0191 

WRITE( 5,1450)  (IMONTH(I) , I=IBEG, TEND) 

!  WANT  DIFFERENT  MONTH? 

0192 

READ (5,1050)  NANS 

1 

OPERATOR  RESPONSE 

0193 

I F ( NANS . NE . ' Y 1 )  GOTO  80 

1 

DIFFERENT  MONTH  WANTED 

0194 

END  IF 

I 

END  IF  BLOCK 

0195 

CALL  ICLR 

f 

CLEAR  SCREEN 

0196 

WRITE (5,1245) 

| 

MONTH  PROMPT 

0197 

READ (5,1360) NSN 

1 

OPERATOR  INPUTS  MONTH 

0198 

80 

I F ( NSN . LT . 1 . OR . NSN . GT . 1 2 )  GO  TO  70 

1 

GO  BACK,  INVALID  MONTH 

0199 

I F  (  . NOT . MAPFLG )  GOTO  90 

j 

NO  MAP,  SKIP  NEXT 

0200 

IF(IANS.EQ.l)  GOTO  100 

i 

IF  OPERATIONAL 

0201 

IF ( INSSP.EQ.2)  GOTO  100 

J 

HISTORICAL  SSP 

0202 

CALL  ICLR 

; 

CLEAR  SCREEN 

0203 

CALL  LATLNG ( 1 ) 

! 

OPERATOR  INPUTS  LAT(l) 

0204 

CALL  LATLNG ( 2 ) 

1 

OPERATOR  INPUTS  LNG ( 2 ) 

0205 

IF( INSSP.EQ. 5)  GO  TO  90 

I 

KEYPUNCH,  SKIP  PROMPT 

0206 

CALL  ICLR 

1 

• 

CLEAR  SCREEN 

)207 

WRITE( 5,5010) 

OCEAN  PROMPT 

0208 

READ (5,1360)  NOC 

| 

OPERATOR  INPUTS  OCEAN 

0209 

90 

CALL  ICLR 

j 

CLEAR  SCREEN 

0210 

WRITE( 5,1170) 

1 

MGS  PROVINCE  PROMPT 

0211 

READ (5,1360)  MGS 

• 

OPERATOR  INPUTS  MGS  # 

0212 

I F ( MGS . LT . 1 . OR . MGS . GT . 9 )  GO  TO  90 

1 

INVALID,  TRY  AGAIN 

0213 

IF( INSSP.EQ. 5)  GO  TO  200 

1 

GO  TO  CALL  SSP 

0214 

CALL  ICLR 

t 

CLEAR  SCREEN 

0215 

WRITE( 5,5000) 

I 

SSP  AREA  INDEX  PROMPT 

0216 

READ (5, 1360)  INDX 

[ 

INPUTS  SSP  AREA  INDEX 

0217 

CALL  ICLR 

I 

CLEAR  SCREEN 

0218 

WRITE( 5,6000) 

1 

BOTTOM  DEPTH  PROMPT 

0219 

READ (5,1370)  BDF 

1 

INPUTS  BOTTOM  DEPTH 

0220 

100 

CALL  SVPRO(NSN) 

1 

GET  HISTORICAL  SSP 

0221 

IF ( INSSP.EQ. 1. OR. INSSP.EQ. 4)  CALL 

BT ( INSSP , NBT)  !  INPUTS  BT 

0222 

200 

IF( INSSP.EQ. 5)  CALL  SSP(INSSP) 

; 

OPERATOR  INPUTS  SSP 

0223 

IF(NANS.EQ. 'Y' )  THEN 

! 

DIFFERENT  MONTH  WANTED 

0224 

IBEG=NSN*3-2 

I 

SET  POINTER 

0225 

BTDATE ( 4 ) = IMONTH ( I BEG ) 

i 

RESET  BT  DATE 

0226 

BTDATE ( 5 ) = I MONTH ( IBEG+1) 

! 

RESET  BT  DATE 

0227 

BTDATE ( 6 ) = IMONTH ( IBEG+2) 

1 

RESET  BT  DATE 

0228 

END  IF 

i 

END  IF  BLOCK 

0229 

CALL  ICLR 

i 

CLEAR  SCREEN 

0230 

WRITE( 5,1400) 

! 

t 

WIND  SPEED  PROMPT 

0231 

READ (5,1370)  WS 

1 

INPUTS  WIND  SPEED 

0232 

MGSOP=MGS 

1 

» 

MGS  PROVINCE 

0233 

RETURN 

)234 

A  *5  *3  C 

) 

A  r-p  Crp  A  qntTXifU'XTrnC  — 

U  L  J  0 

rUKMAi  o  1 A  1  CjM-CjiN  1  o - 

0236 

ioso 

FORMAT (Al) 

e.-a'LV 


0237 

1170 

FORMAT ( /1H$ , 4X, ’****ENTER  MGS  PROVINCE  ( 1-9 )****’ ,T60 , ’  ’) 

0238 

1245 

FORMAT (/5X, ' ****ENTER  MONTH  YOU  WANT  PREDICTIONS  FOR****’, 

?239 

1 

/// ,8X,  '  1  =  JANV8X/2  =  FEB,  ETC.’,T60,’  ’$) 

0240 

1360 

FORMAT (14) 

0241 

1370 

FORMAT (F10.0) 

0242 

1400 

FORMAT ( /1H$ , 4X , '****ENTER  TRUE  WIND  SPEED  (XX  KTS )****', T60 , 

0243 

0244 

1450 

FORMAT ('  THE  CURRENT  MONTH  IS  ',3A1/'  DO  YOU  WANT  TO  DO' 

1  '  PREDICTIONS  FOR  A  DIFFERENT  MONTH?  ’,$) 

0245 

3006 

FORMAT ( '  ****ENTER  AREA  NAME****',$) 

0246 

3007 

FORMAT ( 2 0A1) 

0247 

5000 

FORMAT ('  ENTER  SSP  INDEX  #',T60,'  ',$) 

0248 

5010 

FORMAT (//'  1  =  NORTH  PACIFIC'// 

0249 

1 

'  2  =  NORTH  ATLANTIC’// 

0250 

2 

'  3  =  MEDITERRANEAN'// 

0251 

3 

'  4  =  INDIAN’// 

0252 

4 

'  5  =  NORWEGIAN'//// 

0253 

5 

’  ENTER  OCEAN  AREA  CODE’,T60,'  ',$) 

0254 

6000 

FORMAT ('  ENTER  BOTTOM  DEPTH  IN  FATHOMS ', T6 0 , '  ',$) 

0255 

0256 

6050 

FORMAT ('  ENTER  SALINTY  (TYPICAL  VALUE  =35)  ',$) 

END 

c-ars 


0001 
0002 
)  0  0  3 
0004 
0005 
0006 
0007 
0008 
0009 
0010 
0011 
0012 
0013 
0014 
0015 
0016 
0017 
0018 
0019 
0020 
0021 
0022 
0023 
0024 
0025 
0026 
0027 


INTEGER* 2  FUNCTION  KMOD(l,J) 

PROLOGUE: 

MODULE  NAME:  KMOD 

AUTHOR:  E.  PETR IDES  &  P.  FRAGEORGI A  OF  SYSCON,  INC 

RECODED:  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  1982  &  6/84  (FORTRAN  77) 

FUNCTION:  THIS  FUNCTION  IS  DESIGNED  TO  CALCULATE  THE  CLOCK 
ARITHMETIC  MODULUS  OF  THE  TWO  PARAMETERS  PASSED. 
INPUTS:  INTEGER*2S  TO  BE  USED  IN  CALCULATIONS 
OUTPUTS:  MODULO  DIVISOR  AND  CLOCK  ARITHEMTIC  MODULUS 
MODULES  CALLED:  NONE 
CALLED  BY:  CNNCT ,  DNUT,  END1 ,  END2 

VARBL  SIZE  PURPOSE  TYPE  RANGE 


I  MODULO  DIVISOR  INTEGER* 2 

J  CLOCK  ARITHMATIC  MODULUS  INTEGER* 2 


INTEGER* 2  I,J 

KMOD= IMOD ( I , J) 

IF  ( I * J . LT . 0 )  KMOD=J +KMOD 
IF  (J.EQ.0)  KMOD=0 

RETURN 

END 


!  INTEGER*2  REMAINDER  OF  I/J 
!  CLOCK  ARITHMETIC  TOTAL 
!  IF  MODULO  J  IS  0,  KMOD  IS  0 

!  RETURN  TO  CALLING  ROUTINE 
!  END  FUNCTION 


COMMAND  QUALIFIERS 

FORTRAN  /CHECK= ALL/ LI ST/SHOW=( INCLUDE, NOMAP)  DBA3 : [ LAFLEUR ] KMOD . F7 7 ; 1 

/ CHECK = ( BOUNDS , OVERFLOW , UNDERFLOW ) 

/DEBUG= ( NOSYMBOLS , TRACEBACK ) 

/STANDARD= ( NOSYNTAX , NOSOURCE_FORM ) 

/ SHOW= ( NOPREPROCESSOR , I NCLUDE , NOMAP ) 

/F77  /NOG  FLOATING  /I4  /OPTIMIZE  /WARNINGS  /NOD  LINES  /NOCROSS  REFERENCE 


COMPILATION  STATISTICS 


Run  Time: 
Elapsed  Time: 
Page  Faults: 
Dynamic  Memory: 


0.48  seconds 
1.06  seconds 
306 

105  pages 


C-30.( 


0001 
0002 
>003 
0004 
0005 
0006 
0007 
0008 
0009 
0010 
0011 
0012 
0013 
0014 
0015 
0016 
0017 
0018 
0019 
0020 
0021 
0022 
0023 
0024 
0025 
0026 
0027 
0028 
0029 
)  0  3  0 
0031 
0032 
0033 
0034 
0035 
0036 
0037 
0038 
0039 
0040 
0041 
0042 
0043 
0044 
0045 
0046 
0047 
0048 
0049 
0050 
0051 
0052 
0053 
0054 
0055 
0056 
JO  57 
0058 
0059 


SUBROUTINE  KSCAT ( BIOPl , BIOP2 , UMKZ) 

PROLOGUE : 

MODULE  NAME:  KSCAT 

AUTHOR:  S.  LAFLEUR  &  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  5/84  &  5/84  (FORTRAN  77) 

FUNCTION:  SUBROUTINE  KSCAT  ALLOWS  THE  OPERATOR  TO  INPUT 
SCATTERING  AND  BACK-SCATTERING  COEFFICIENTS. 
INPUTS:  HARD  COPY  SELECTION,  OPERATOR  INPUTS 
OUTPUTS:  CRT  PROMPTING  MESSAGES  TO  OPERATOR 
MODULES  CALLED:  ICLR 
CALLED  BY:  KEYPCH 

VARBL  SIZE  PURPOSE 


BIOP1  DAY  BIO  SCATTERING  COEFFICIENT 

BIOP2  NIGHT  BIO  SCATTERING  COEFF 

JANS  OPERATOR  RESPONSE 

UMKZ  BOTTOM  BACK-SCATTERING  COEFF 

INTEGER* 2  JANS 
REAL *4  BIOPl , BIOP2 , UMKZ 

BIOPl=  -57. 

BIOP2=  -47. 

UMKZ=  -28. 

CALL  ICLR 
WRITE (5,4000) 

WRITE (5,4007) 

READ( 5,1360)  JANS 
IF (JANS . NE . 0 )  THEN 
WRITE (5,4010) 

READ( 5 , 1370)  BIOPl 
WRITE ( 5,4020) 

READ (5,1370)  BIOP2 
END  IF 
CALL  ICLR 
WRITE (5,4003) 

WRITE (5,4007) 

READ( 5,1360)  JANS 
IF (JANS . EQ . 0 )  THEN 
WRITE( 5,4030) 

READ( 5,1370)  UMKZ 
END  IF 
CALL  ICLR 
RETURN 

FORMAT  STATEMENTS - 

FORMAT ( 14) 

FORMAT (FI 0.0) 

FORMATC  BIO  SCATTERING  COEFF. S  ENTRY') 

FORMAT (’  BOTTOM  BACK- SCATTERING  COEFF. S  ENTRY') 

FORMAT (//'  0  =  USE  DEFAULT  VALUES’/ 

'  1  =  OPERATOR  INPUT'// 

'***  ENTER  YOUR  CHOICE  ***',T58,$) 

FORMATC  ENTER  DAYTIME  BIO  SCATTERING  COEFF .', T58 ,$ ) 
FORMATC  ENTER  NIGHTIME  BIO  SCATTERING  COEFF .', T58 ,$ ) 
FORMATC  ENTER  BOTTOM  BACK -SCATTERING  COEFF. ’, T58 ,$ ) 
END 


1360 

1370 

4000 

4003 

4007 

1 

2 

4010 

4020 

4030 


DAY  BIO  SCATTERING  COEFF. 

NIGHT  BIO  SCATTERING  COEFF. 
BOTTOM  BACK -SCATTERING  COEFF. 
CLEAR  SCREEN 

BIO  SCATTERING  COEFF.  TITLE 
PROMPT  SELECTION 
OPERATOR  SELECTION 
OPERATOR  INPUT  BIO.  SCAT. 

DAY  BIO  SCAT.  COEFF.  PROMPT 
INPUTS  DAY  BIO.  SCAT.  COEFF. 
NIGHT  BIO  SCAT.  COEFF.  PROMPT 
INPUTS  NIGHT  BIO.  SCAT.  COEFF. 
END  IF  BLOCK 
CLEAR  SCREEN 

BOTTOM  BIO  SCAT.  COEFF.  PROMPT 
SELECTION  PROMPT 
OPERATOR  SELECTION 
OPERATOR  INPUT  BOT .  BACK-SCAT. 
BOT.  BACK-SCAT.  COEFF.  PROMPT 
INPUTS  BOT.  BACK-SCAT.  COEFF. 
END  IF  BLOCK 
CLEAR  SCREEN 

RETURN  TO  CALLING  ROUTINE 


TYPE  RANGE 


REAL *4  -57 

REAL *4  -47 

INTEGER* 2 
REAL *4 


c -si. i 


0001  SUBROUTINE  LATLNG ( OPT ) 

)002 

0003  !  PROLOGUE: 

0004  !  MODULE  NAME:  LATLNG 

0005  !  AUTHOR:  S.  LAFLEUR  &  W.  WACHTER,  CODE  3333,  NUSC/NLL 

0006  !  DATE:  1982  &  12/83  (FORTRAN  77) 

0007  !  FUNCTION:  SUBROUTINE  LATLNG  PRODUCES  EITHER  THE  LATITUDE 

0008  !  OR  LONGITUDE  FOR  THE  SHIP'S  LOCATION.  OPTION  1  IS 

0009  !  FOR  LATITUDE.  OPTION  2  IS  FOR  LONGITUDE. 

0010  !  INPUTS:  PARAMETERS  PASSED  IN.  VARIABLES  IN  COMMONS.  SEE  NOTE. 

0011  !  OUTPUTS:  CRT  PROMPTING  MESSAGES  TO  OPERATOR. 

0012  !  MODULES  CALLED:  NONE 

0013  !  CALLED  BY:  KEYPCH 

0014  ! 

0015  ! - 

0016  !  NOTE:  THE  USER  INPUT  IS  A  BUFFER  OF  UP  TO  12  CHARACTERS  LONG  WITH 

0017  !  EACH  PARAMETER  SEPARATED  BY  EITHER  COMMAS  OR  BLANKS. 

0018  !  THE  FORMAT  IS  <SDDD><MM><CC><R>  WHERE: 

0019  !  S=THE  SIGN  (EITHER  OR  NOTHING) 

0020  !  DEFAULT:  '+'  UNLESS  'S’  OR  'W'  SET 

0021  !  _  D=THE  DEGREES  (0  =  80  FOR  LAT)  (0  =  180  FOR  LONG) 

0022  !  M=THE  MINUTES  (0  =  59) 

0023  !  C=THE  SECONDS  (0  =  59) 

0024  !  R= THE  DIRECTION  (EITHER  ' S ' , ' N ' , ' E ' , ' W'  OR  NOTHING) 

0025  !  DEFAULT:  'N'  OR  'E'  UNLESS  '=’  SET 

0026  ! - 

0027  ! 

0028  INCLUDE  'LOC.INC' 

JO  29  1  ! - LOC - 

0030  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0031  1  !  - -  -  -  - 

0032  1  !  INDX  SSP  INDEX  INTEGER* 2 

0033  1  !  LAT  (4)  LATITUDE  INTEGER* 2 

0034  1  !  LONG  (4)  LONGITUDE  INTEGER* 2 

0035  1  !  NMAREA  (20)  AREA  OCEAN  NAME  BYTE 

0036  1  !  NOC  NUMBER  OF  OCEAN  INTEGER* 2 

0037  1  !  RCZ  RANGE  TO  CONVERG...  ZONE  REAL *4 

0038  1 

0039  1  REAL *4  RCZ 

0040  1  INTEGER* 2  I NDX , L AT , LONG , NOC 

0041  1  BYTE  NMAREA ( 20 ) 

0042  1 

0043  1  COMMON  /LOC/  LAT( 4 ), LONG ( 4 ), NOC , INDX , RCZ , NMAREA 

0044  1 

0045  1  ! - END  LOC - 

0046  ! 

0047  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0048  !  - -  -  -  - 

0049  !  BUF  (12)  BUFFER  PASSED  IN  BYTE 

0050  !  FLAG  (3)  ERROR  FLAG  BYTE  TRUE/FALSE 

0051  !  I  'COUNTER  INTEGER* 2 

0052  !  J  COUNTER  INTEGER* 2 

0053  !  LEN  LENGTH  OF  BUFFER  INTEGER* 2 

0054  !  MAXVAL  (3)  MAXIMUM  VALUE  OF  T  INTEGER* 2  180,59,59 

0055  !  MINUS  HEMISPHERE  FLAG  BYTE  TRUE/FALSE 

/056  !  NSEW  (2,2)  HEMISPHERE  1 S ' , ' N' , ’ W' , ' E'  BYTE  S,N,W,E 

0057  !  NUMBER  FLAG  FOR  EXISTANCE  OF  NUMBERS  BYTE  TRUE/FALSE 

0058  !  ONE  FLAG  FOR  OPTION  1  (LATITUDE)  BYTE  TRUE/FALSE 

0059  !  OPT  LATITUDE ( 1 )  OR  LONGITUDE( 2 )  OPTION  INTEGER* 2  1  OR  2 
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0060  !  SIGN  FLAG  FOR  PLUS  OR  MINUS  SIGN  BYTE  TRUE/FALSE 

)0  6 1  !  SPEC  (3)  '  DEGREE',  '  MINUTE',’  SECOND'  ARRAY  REAL  *8 

0062  !  T  (3)  NUMBERICAL  SPECIFICATION  OF  SPEC  INTEGERS 

0063  !  TWO  FLAG  FOR  OPTION  1  (LATITUDE)  BYTE  TRUE/FALSE  ; 

0064  !  W  BUFFER  POINTER  INTEGER* 2 

0065  ! 

0066  !  ***  VARIABLES  NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMON  *** 

0067 

0068  INTEGER*2  I , J , LEN , MAXVAL ( 3 ) , OPT , T ( 3 ) , W 

0069  REAL *8  SPEC<3) 

0070  BYTE  BUF(12) ,NSEW(2, 2) , ONE, TWO, FLAG(3) , MINUS, SIGN, NUMBER 

0071  DATA  NSEW/'S' , 'N' , 'W* , 'E'/, 

0072  1  SPEC/'  DEGREE','  MINUTE', '  SECOND'/, 

0073  2  MAXVAL/180, 59, 59/ 

0074 

0075  ! =================================== ====PRELIMINARIES=============== 

0076  ONE= ( OPT . EQ . 1 )  !  SET  OPTION  1  FLAG  ( LAT ) 

0077  TWO= ( OPT . EQ . 2 )  !  SET  OPTION  2  FLAG  (LONG) 

0078  1  T ( 1 ) =0  !  INITIALIZE  DEGREES 

0079  T(2)=0  !  INITIALIZE  MINUTES 

0080  _  T ( 3 ) =0  !  INITIALIZE  SECONDS 

0081  FLAG(1)=. FALSE.  !  RESET  ERROR  FLAGS 

0082  FLAG (  2  )  =  . FALSE .  !  RESET  ERROR  FLAGS 

0083  FLAG ( 3 ) = . FALSE .  !  RESET  ERROR  FLAGS 

0084  NUMBER=. FALSE.  !  RESET  NUMBER  FLAG 

0085 

0086  ! - GET  DATA  STRING  (LAT  OR  LONG) - 

Q087  IF  (ONE)  THEN  !  OPTION  1 

)088  WRITE (5, 2)  !  INPUT  LATITUDE 

0089  ELSE  !  OPTION  2 

0090  WRITE (5, 4)  !  INPUT  LONGITUSE 

0091  END  IF  !  END  IF  BLOCK 

0092  READ (5,6)  LEN, BUF  !  GET  BUFFER 

0093  IF  (LEN.EQ.0)  GOTO  101  !  ILLEGAL  ENTRY  ERROR 

0094 

0095  ! =========================== ============PARSE  THE  INPUT  STRING======= 

0096  DO  7  1=1, LEN  !  CHECK  FOR  ALL  BLANKS 

0097  IF  (BUF(I).NE.'  ')  GOTO  8  !  NON-BLANK  FOUND 

0098  7  CONTINUE  !  END  DO  LOOP 

0099  GOTO  101  !  ILLEGAL  ENTRY  ERROR 

0100 

0101  ! - PARSE  +  OR  -  SIGN  (IF  PRESENT) 

0102  8  W=0  !  SET  BEGINNING  OF  THE  BUF 

0103  MINUS=. FALSE.  !  DEFAULT  POSITIVE  HEMISPHERE 

0104  SIGN=. FALSE,  !  DEFAULT  NO  SIGN  PRESENT 

0105  IF  ( BUF ( W+ 1 ) . NE . ' + '  .AND.  BUF ( W+ 1 ) . NE . ' - ' )  GOTO  9  !  NO  SIGN 

0106  W=1  !  GET  NEXT  CHAR 

0107  MINUS= (BUF(W) . EQ. ' - ' )  !  SET  FLAG  ACCORDING  TO  +  - 

0108  S IGN= . TRUE .  !  THERE  IS  A  SIGN 

0109  IF  (W.EQ.LEN)  GOTO  103  !  NOT  LAT  OR  LONG  INPUT  ERROR 

0110 

0111  ! - PARSE  DEGREE,  MINUTE,  &  SECOND  #S  AND/OR  DELIMITERS 

0112  9  DO  12  1=1,3  !  DO  THREE  TIMES 

0113  DO  10  J=1 , 4  !  DO  FOUR  TIMES 

0114  W=W+1  !  CHECK  FOR  DELIMITERS  OR  #S 

)115  IF  (BUF(W).EQ.'  '  .OR.  BUF(W) .EQ. ' , ' )  GOTO  11  !  ERROR 

0116  IF  (BUF(W) .LT. '0*  .OR.  BUF( W) .GT. ’ 9 ' )  GOTO  13  !  ERROR 

0117  T ( I ) =T( I ) *10+ ( BUF (W) -48 )  !  ASCII  TO  INTEGER* 2 

0118  NUMBER= . TRUE .  !  FLAG  A  LEAST  ONE  NUMBER  SET 
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0119 

YL20 

J121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

YL47 

>3148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 

0161 

0162 

0163 

0164 

0165 

0166 

0167 

0168 

0169 

0170 

0171 

0172 

0173 

1174 

0175 

0176 

0177 


10  CONTINUE  !  END  DO  LOOP 

11  FLAG ( I ) = ( T ( I ) . GT . MAXVAL ( I ) )  !  SET  FLAG  FOR  ERROR 

12  CONTINUE  !  END  DO  LOOP 

; - PARSE  OFF  DELIMITER  FOR  HEMISPHERE  (IF  ANY) 

13  IF  ( .NOT. NUMBER)  GOTO  103  !  CHECK  TO  SEE  IF  ANY  #  SET 

14  IF  (W.GT.LEN)  GOTO  16  !  CHECK  CURRENT  LENGTH 

IF  (BUF(W).NE.'  ' .AND.BUF(W) .NE. ' , ' )  GOTO  15  !  NO  HEMISPHERE 


W=W+1  !  SKIP  DELIMITERS 

GOTO  14  !  START  AGAIN 


; - PARSE,  CHECK,  AND  SET  HEMISPHERE  (N,S,E,OR  W) 

15  IF  ( BUF ( W ) . NE . NSEW ( 1 , OPT )  .AND.  BUF(W) .NE.NSEW( 2 ,OPT) ) 

1  GOTO  101  !  ILLEGAL  ENTRY  ERROR 

IF  (SIGN  .AND.  (MINUS  .XOR.  (BUF(W) .EQ.NSEW( 1 ,OPT) ) ) ) 

1  GOTO  105  !  SIGN  CONFLICT  ERROR 

MINUS= ( BUF ( W) . EQ . NSEW( 1 , OPT ) )  !  SET  HEMISPHERE  SIGN 


j  - 

i.6 


18 


OUTPUT  ERRORS  OF  DEGREES.  MINUTES.  SECONDS 


DO  18  1=1,3 

IF  (FLAG(I))  THEN 
WRITE( 5,17)  SPEC ( I ) 
WRITE ( 5,1002) 

FLAG( 1 ) =FLAG( 1 ) +FLAG ( I ) 
END  IF 
CONTINUE 

IF  (FLAG(l))  GOTO  1 


!  PRINT  OUT  SPEC  ERRORS 
!  ERROR  FLAG 
!  ERROR  -  ILLEGAL  SPEC 
!  TRY  AGAIN 
!  RESET  FLAG 
!  END  IF  BLOCK 
!  END  DO  LOOP 

!  IF  ANY  FLAG  SET,  TRY  AGAIN 


=s=  =  =:  =  =  =  =  =  =  =  =  =  =  ;s  =  s=ss  =  =  SET  FINAL  LATITUDE  OR  LONGITUDE  PARAMETERS 


SIGN=2*MINUS+1 
IF  (ONE)  THEN 
LAT ( 1 ) =T ( 1 ) 

LAT ( 2 ) =T ( 2 ) 

LAT ( 3 ) =T ( 3 ) 

LAT ( 4 ) = ' S ' 

IF(SIGN.EQ.l)  LAT (  4  )  = '  N ' 
ELSE 

LONG( 1 ) =T ( 1 ) 

LONG( 2 ) =T( 2 ) 

LONG ( 3 ) =T ( 3 ) 

LONG ( 4 ) = ' W ' 

IF ( SIGN. EQ . 1 )  LONG ( 4 ) = ' E ' 
END  IF 
RETURN 


SET  SIGN  OF  LAT  OR  LNG 
OPTION  1 

DEGREES  LATITUDE  FOR  SIMAS 

MINUTES  LATITUDE  FOR  SIMAS 

SECONDS  LATITUDE  FOR  SIMAS 

SOUTH 

NORTH 

OPTION  2 

DEGREES  LONGITUDE  FOR  SIMAS 
MINUTES  LONGITUDE  FOR  SIMAS 
SECONDS  LONGITUDE  FOR  SIMAS 
WEST 
EAST 

END  IF  BLOCK 

RETURN  TO  CALLING  ROUTINE 


iol 


103 


105 


WRITE ( 5 , 102 ) 
WRITE( 5 , 1002 ) 
GOTO  1 
WRITE (5,104) 
WRITE (5,1002) 
GOTO  1 
WRITE( 5,106) 
WRITE( 5 , 1002 ) 
GOTO  1 


ERRORS=== =================== 

!  ILLEGAL  ENTRY  ERROR 
!  TRY  AGAIN 
!  START  OVER 

!  NOT  LAT  OR  LONG  INPUT  ERROR 
!  TRY  AGAIN 
!  START  OVER 
!  SIGN  CONFLICT  ERROR 
!  TRY  AGAIN 
!  START  OVER 


! ======= FORMAT  STATEMENTS== ============================= ============== 

2  FORMAT ( X ,' ENTER  LATITUDE  <DEG> , <MIN> , <SEC> , < ' ' N ' '  OR  ''S''>  '$) 

4  FORMAT  (X, 'ENTER  LONGITUDE  <DEG>  ,  <MIN> ,  <SEC> ,  <  '  '  E  '  '  OR  "V">  '  $) 


C  -  32.1 3 


0178 

6 

FORMAT (Q, 1 2 Al) 

)179 

17 

FORMAT ( X , ' *** 

ERROR , 

0180 

102 

FORMAT ( X , ' *** 

ERROR, 

0181 

104 

FORMAT (X, ' *** 

ERROR , 

0182 

106 

FORMAT (X, ' *** 

ERROR, 

0183 

1002 

FORMAT ( ' + ,  TRY 

AGAIN 

0184 

END 

ILLEGAL' ,A8, ' SPECIFICATION '$ ) 

ILLEGAL  ENTRY'?) 

NO  LONGITUDE  OR  LATITUDE  INPUT'S) 
CONFLICTING  DEGREES  SIGN  AND  HEMISPHERE'?) 
***  '  ) 


COMMAND  QUALIFIERS 

FORTRAN  /CHECK= ALL/L I ST/SHOW=( INCLUDE, NOMAP)  [ LAFLEUR ] LATLNG . F7 7 

/CHECK= ( BOUNDS , OVERFLOW , UNDERFLOW ) 

/DEBUG= ( NOSYMBOLS , TRACEBACK ) 

/ STANDARD= ( NOSYNTAX , NOSOURCE_FORM ) 

/ SHOW= ( NOPREPROCESSOR , INCLUDE , NOMAP ) 

/F77  /NOG  FLOATING  /I4  /OPTIMIZE  /WARNINGS  /NOD  LINES  /NOCROSS  REFERENCE 


COMPILATION  STATISTICS 


Run  Time: 
Elapsed  Time: 
Page  Faults: 
Dynamic  Memory: 


3.24  seconds 
9.32  seconds 
385 

152  pages 


0001 
0002 
1)003 
0004 
0005 
0006 
0007 
0008 
0009 
0010 
0011 
0012 
0013 
0014 
0015 
0016 
0017 
0018 
0019 
0020 
0021 
0022 
0023 
0024 
0025 
0026 
0027 
0028 
■<30  29 
>0  30 
0031 
0032 
0033 
0034 


SUBROUTINE  LAYER ( N ,  Z ,  C , DL YR ) 


PROLOGUE : 

MODULE  NAME:  LAYER 

AUTHOR:  G.  BROWN  &  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  1974  &  12/83  (FORTRAN  77) 

FUNCTION:  SUBROUTINE  LAYER  EXAMINES  THE  SOUND  VELOCITY  PROFILE 
DATA  ARRAYS  TO  DETERMINE  THE  DEPTH  OF  THE  SURFACE 
DUCT  LAYER. 

INPUTS:  PARAMETERS  PASSED  IN:  C,N,Z 

OUTPUTS:  PARAMETER  PASSED  OUT:  DLYR 
MODULES  CALLED:  NONE 
CALLED  BY:  ENV I RN , FORCST , XBT 

VARBL  SIZE  PURPOSE  TYPE  RANGE 


C  (50) 

DLYR 
J 
N 

Z  (50) 


VELOCITY 
LAYER  DEPTH 
COUNTER 
INDEX 
DEPTH 


REAL *4 
REAL* 4 
INTEGER* 2 
INTEGER* 2 
REAL *4 


INTEGER* 2  J,N 
REAL *4  C, DLYR, Z 

DIMENSION  Z( 50 ) ,C( 50 ) 


400 

500 


DO  400  J=2 , N 

IF(C(J) .LT.C(J-l) )  GO  TO  500 
CONTINUE 
J=N+1 

DLYR=Z( J-l ) 


!  DO  FROM  2  TO  INDEX 
!  VELOCITY  <  PREVIOUS 
!  END  DO  LOOP 
!  SET  COUNTER 

!  LAYER  DEPTH  =  DEPTH ( J-l) 


RETURN 

END 


!  RETURN  TO  CALLING  ROUTINE 
!  END  SUBROUTINE 


C-  33.  I 


18-Dec-1984  13:00:03 
18-Dec-1984  13:00:02 


III 

0003 
0004 
0005 
0006 
0007 
0008 
0009 
0010 
0011 
0012 
0013 
0014 
0015 
0016 
0017 
0018 
0019 
0020 
0021 
0022 
0023 
0024 
0025 
0026 
0027 
P  ’’8 
1^9 
0030 
0031 
0032 
0033 
0034 
0035 
0036 
0037 
0038 
0039 
0040 
0041 
0042 
0043 
0044 
0045 
0046 
0047 
0048 
0049 
0050 
0051 
0052 
0053 


SUBROUTINE  LEROY ( ZF,TF,S ,V) 

I  PROLOGUE: 

!  MODULE  NAME:  LEROY 

1  AUTHOR:  G.  BROWN  &  W.  WACHTER,  CODE  3333,  NUSC/NLL 
!  DATE:  1974  &  12/83  (FORTRAN  77) 

!  FUNCTION:  SUBROUTINE  LEROY  CONVERTS  A  DEPTH /TEMPERATURE  PAIR 
I  INTO  A  DEPTH/ SOUND  VELOCITY  PAIR. 

1  INPUTS:  PARAMETERS  PASSED  IN:  ZF,TF,S 
1  OUTPUTS:  PARAMETERS  PASSED  OUT:  V 
l  MODULES  CALLED:  NONE 
l  CALLED  BY:  METRIC ,VELTMP ,XBT 


!  ALGORITHMS  USED: 

i 

l  SOUND  VELOCITY  IN  FEET/ SEC  =  SOUND  VELOCITY  IN  METERS /SEC 
!  DIVIDED  BY  0.3048006 


VARBL  SIZE  PURPOSE 


TYPE  RANGE 


!  FTOM  FEET  TO  METERS  CONVERSION  REAL*4  0.3048006 

!  PSI  PRESSURE  KG/ CM** 2  REAL* 4 

!  S  SALINITY  REAL*4 

!  T  TEMPERATURE  CENTIGRADE  REAL* 4 

!  TF  TEMPERATURE  FARENHITE  REAL *4 

!  V  VELOCITY  REAL* 4 

!  VA  SOUND  VEL  FROM  SALINITY  REAL* 4 

!  VB  SOUND  VEL  FROM  PRESSURE  REAL* 4 

l  VY  REAL* 4 

!  VZ  REAL*4 

!  VO  SOUND  VEL  FROM  TEMPERATURE  REAL *4 

I  Z  DEPTH  IN  METERS  REAL*4 

l  ZF  DEPTH  IN  FEET  REAL*  4 

I 


REAL* 4  FTOM, PSI ,S ,T ,TF,V,VA, VB , VY,VZ ,V0 ,Z ,ZF 
DATA  FTOM/ 0.3048006/ 


Z=FTOM*ZF  !  CONVERT  INPUT  DEPTH  TO  METERS 

PSI=0.001*Z  l  PRESSURE  KG/CM**2 

T=5.*(TF-32. )/9.  !  CONVERT  TEMPERATURE  TO  CENTIGRADE 

VY=  (  3.-0.006MT-10.  )  ) 

VZ=  (4.*(T-18. ) +( S-35 . ) ) 

V0=1492.9+(T-10. )*VY-0.01*(T-18. ) *VZ+1 . 2*( S-35 . ) +Z/61 
!  VO  =  1492 . 9+(T-10 . ) * ( 3 . -0 . 006* (T- 10 . ) ) -0 . 01* ( T-18 . ) *  !  SOUND  VEL: 

!  1  ( 4 . *(T-18 .  )  +  ( S-35 .  )  )  +1 . 2*( S-35 .  ) +Z/61  i  FROM  SALINITY 

VA=0 . 1*PSI*( PSI+0 . 5) +0 . 0002*( PSI*(T-18 . ) ) **2  l  FROM  PRESSURE 
VB=2.E-7*T*(T-10. )**4  !  FROM  TEMPERTURE 

V=(V0+VA+VB) /FTOM  !  CONVERT  FROM  METERS/SEC  TO  FEET/SEC 

RETURN  !  RETURN  TO  CALLING  ROUTINE 

END  1  END  SUBROUTINE 
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0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 

0011 

0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 

0021 

0022 

0023 

0024 

0025 

0026 

0027 

0028 


SUBROUTINE  LNTYPE ( L I NTYP ) 

PROLOGUE : 

MODULE  NAME:  LNTYPE 

AUTHOR:  J.  CASCIO,  W.  WACHTER ( FORTRAN  77),  NUSC/NL,  CODE  3333 

DATE:  1981  &  9/84  (FORTRAN  77) 

FUNCTION:  SETS  THE  LINE  TYPE  FOR  DRAWING  OR  ERASING  LINES 

INPUTS:  TYPE  TO  SET  LINE  TYPE  TO 

OUTPUTS:  SET  LINE  TYPE 

MODULES  CALLED:  NONE 

CALLED  BY:  PLT25 ,  SVPGRF 

VARBL  SIZE  PURPOSE  TYPE  RANGE 


!  I TYPE  POINTER  FOR  LINTYP  ARRAY  INTEGER* 2 

!  LINTYP  (10)  ARRAY  OF  TYPES  OF  LINES  AVAILABLE  INTEGER* 2 

j 

INTEGER* 2  LINTYP, ITYPE 
DIMENSION  ITYPE (10) 

DATA  ITYPE/ ,1,,’2,,'3,,'4,,,5',,6’,,7,,’8,,'P,,'E'/ 

IF  (LINTYP.LT. 1  .OR.  LINTYP. GT. 10)  LINTYP=1  !  INVALID,  SET  TO  SO 

WRITE (5,1)  ITYPE (LINTYP)  !  SET  LINE  TYPE 

RETURN  !  RETURN  TO  CALLING  ROUTINE 

! - FORMAT  STATEMENT - 

1  FORMAT ('  ! LIN  ' ,A1) 

END 


O  ST,  / 


0001  SUBROUTINE  LYRMOD ( NBT , DLYR , NDLYR, HLYR) 

■0002 

0003  !  PROLOGUE: 

0004  !  MODULE  NAME:  LYRMOD 

0005  !  AUTHOR:  S.  LAFLEUR,  W.  WACHTER  (FORTRAN  77) 

0006  !  DATE:  7/84  &  7/84  (FORTRAN  77) 

0007  !  FUNCTION:  SUBROUTINE  LYRMOD  MODIFIES  THE  BT  LAYER  DEPTH  TO 

0008  !  BE  PLUS  OR  MINUS  50  FEET  OF  THE  HISTORICAL  LAYER  DEPTH, 

0009  !  WHEN  THE  BT  LAYER  DEPTH  IS  NOT  <  100  FFET  OR  THE  BT  LAYER 

0010  !  DEPTH  IS  NOT  <=  THE  HISTORICAL  LAYER  DEPTH. 

0011  !  INPUTS:  PARAMETERS  PASSED  IN  &  VARIABLES  IN  COMMONS. 

0012  !  OUTPUTS:  MODIFIED  LAYER  DEPTH  AND  SS  AT  LAYER  DEPTH 

0013  !  MODULES  CALLED:  NONE 

0014  !  CALLED  BY:  XBT 

0015  ! 

0016  INCLUDE  'DTV.INC' 

0017  1  ! - 7 - DTV - 

0018  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0019  1  ! -  -  -  - 

0020  1  !  D  (25)  DEPTH  REAL *4 

0021  1  !  DD  (25)  DEPTH  _  REAL*4 

0022  1  !  NNBT  NUMBER  OF  BATHETHERMAL  INTEGER* 2 

0023  1  !  T  (25)  TEMPERATURE  REAL *4 

0024  1  !  TT  (25)  TEMPERATURE  REAL* 4 

0025  1  !  VEL  (25)  VELOCITY  REAL* 4 

0026  1  ! 

0027  1  INTEGER* 2  NNBT 

0028  1  REAL *4  D , DD , T , TT , VEL 

^029  1 

<3030  1  COMMON  /DTV/  D (  25  )  , T(  2 5  )  ,  VEL (  25 )  , DD(  25 )  , TT (  25 )  , NNBT 

00  31  1  ! - END  DTV - 

0032  ! 

0033  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0034  ! -  -  -  - 

0035  !  DEPDIF  DEPTH  DIFFERENCE  REAL *4 

0036  !  DLYR  BT  LAYER  DEPTH  REAL *4 

0037  !  HLYR  HISTORICAL  LAYER  DEPTH  REAL*4 

0038  !  I  LAYER  POSITION  FLAG  INTEGER* 2 

0039  !  NBT  NUMBER  OF  BT  POINTS  INTEGER* 2 

0040  !  NDLYR  BT  LAYER'S  POSITION  IN  ARRAY  INTEGER*2 

0041  ! 

0042  !  ***  VARIABLES  NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMONS  *** 

0043 

0044  INTEGER*2  I , NBT , NDLYR 

0045  REAL *4  DEPDIF, DLYR, HLYR 

0046 

0047  ! - ' MODIFY  LAYER  DEPTH  IF  REQUIRE 

0048  IF(DLYR.LT. 100. .AND. DLYR. LE. HLYR)  GOTO  25  !  SKIP  MODIFICATION 

0049  IF ( DLYR. GT. HLYR+50, ) THEN  !  LAYER  DEEPER  THAN  HI STORICA 

0050  DEPDIF=HLYR+50 . -DLYR  !  SET  DEPTH  DIFF 

0051  DLYR=HLYR+ 50 .  !  SET  MAX  BT  LAYER 

0052  END  IF  !  END  IF  BLOCK 

0053  IF(HLYR-50. .GE.2500. )  THEN  !  HISTORICAL  LAYER  DEEPER  THA 

0054  NBT=NDLYR  !  DO  NOT  CHANGE  LAYER  DEPTH 

0055  GOTO  25  !  TO  2500  FEET  OR  DEEPER. 

\056  END  IF  !  END  IF  BLOCK 

</057  IF(DLYR.  LT. HLYR- 50  .  )THEN  !  LAYER  LESS  THAN  HISTORICAL- 

0058  DEPD IF=HLYR-50 . -DLYR  !  SET  DEPTH  DIFFERENCE 

0059  DLYR=HLYR-50 .  !  SET  MIN  BT  LAYER 


0060 

END  IF 

!  END  IF  BLOCK 

0061 

IF(D(NDLYR) .EQ.DLYR)  GO  TO 

25 

!  SKIP  DEPTH/VELOCITY  CALCULA 

J062 

D(NDLYR) =DLYR 

!  DEPTH 

0063 

VEL ( NDLYR ) = VEL ( NDLYR ) +DEPDI F/6 1 

!  ALLOW  FOR  DEPTH  DIFF 

0064 

0065 

; - 

- ENSURE  LAYER  DEPTH  >  PREVIOUS  DEPTH  IN  ARR 

0066 

25 

I F ( NDLYR. LE . 2 )  GO  TO  100 

!  SKIP  NEXT 

0067 

IF( D( NDLYR) . GT . D ( NDLYR- 1 ) ) 

GOTO 

100!  SKIP  NEXT 

0068 

IF ( NDLYR. GT.NBT)  NDLYR=NBT 

!  CHECK  NDLYR 

0069 

DO  50  I=NDLYR-1 , NBT-1 

!  DO  FROM  LAYER  -  1  TO  NEXT 

T 

0070 

D( I ) =D( 1+1) 

!  DEPTH 

0071 

VEL ( I ) =VEL ( I +1 ) 

!  SS  AT  LAYER  DEPTH 

0072 

50 

CONTINUE 

!  END  DO  LOOP 

0073 

NDLYR=NDLYR- 1 

!  DECREASE  #  OF  LAYER  DEPTHS 

0074 

NBT= NBT-1 

!  DECREASE  #  OF  BTS 

0075 

GO  TO  25 

!  LOOP  BACK 

0076 

0077 

i 

— 

-ENSURE  LAYER  DEPTH  <  NEXT  DEPTH  IN 

A 

0078 

ioo 

I F ( NDLYR . GE . NBT . OR . NDLYR . GE 

.25) 

GO  TO  155  !  SKIP  THIS  SECTION 

0079 

I F ( D ( NDLYR ) . LT. D ( NDLYR+1 ) ) 

GOTO 

155!  SKIP  THIS  SECTION 

0080 

DO  150  I =NDLYR+ 1 , NBT-1 

!  DO  FROM  LAYER  +  1  TO  NEXT 

T 

0081 

D( I ) =D( 1+1 ) 

!  DEPTH 

0082 

VEL ( I ) =VEL ( I +1 ) 

!  SS  AT  LAYER  DEPTH 

0083 

150 

CONTINUE 

!  END  DO  LOOP 

0084 

NBT=NBT-1 

!  DECREASE  #  OF  BTS 

0085 

GO  TO  100 

!  LOOP  BACK 

0086 

0087 

i  - 

- ENSURE  LAYER 

DEPTH  SOUND  SPEED  IS  LOCAL  MAXIM 

0088 

i.55 

I F ( NDLYR. LE . 2 )  GO  TO  165 

!  SKIP  THIS  SECTION 

)089 

IF ( VEL ( NDLYR- 1 ) . LT . VEL ( NDLYR) ) 

GOTO  165  !  SKIP  THIS  SECTION 

0090 

DO  160  I =NDLYR- 1 , NBT-1 

!  DO  FROM  LAYER  -  1  TO  NEXT 

T 

0091 

D( I )=D( 1+1) 

!  DEPTH 

0092 

VEL ( I ) = VEL ( I  + 1 ) 

!  SS  AT  LAYER  DEPTH 

0093 

160 

CONTINUE 

!  END  DO  LOOP 

0094 

NBT = NBT-1 

!  DECREASE  #  OF  BTS 

0095 

NDLYR=NDLYR- 1 

!  DECREASE  #  OF  LAYER  DEPTHS 

0096 

GO  TO  155 

!  LOOP  BACK 

0097 

0098 

165 

I F ( NDLYR . GE . NBT . OR . NDLYR . GE 

.25) 

GO  TO  200  !  SKIP  THIS  SECTION 

0099 

IF( VEL (NDLYR+1) . LT . VEL ( NDLYR ) ) 

GOTO  200  !  SKIP  THIS  SECTION 

0100 

DO  170  I=NDLYR+1 , NBT-1 

!  DO  FROM  LAYER  +  1  TO  NEXT 

T 

0101 

D ( I ) =D ( 1+1) 

!  DEPTH 

0102 

VEL ( I ) =VEL ( 1+1) 

!  SS  AT  LAYER  DEPTH 

0103 

170 

CONTINUE 

!  END  DO  LOOP 

0104 

NBT = NBT-1 

!  DECREASE  #  OF  BTS 

0105 

GO  TO  165 

!  LOOP  BACK 

0106 

0107 

200 

RETURN 

!  RETURN  TO  CALLING  ROUTINE 

0108 

END 

!  END  SUBROUTINE 
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SUBROUTINE  MAP ( MAPFLG ) 

PROLOGUE: 

MODULE  NAME:  MAP 

AUTHOR:  E.  PETR IDES  &  P.  FRAGEORGIA  OF  SYSCON,  INC 

RECODED:  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  1982  &  3/84  (FORTRAN  77) 

FUNCTION:  THIS  ROUTINE  IS  THE  MAPPING  ROUTINE  FOR  NUSC. 

DESIGNED  TO  RETRIEVE  AND  GRAPHICALLY  DISPLAY  MGS  PROVINCE 
AREAS,  SOUND  SPEED  INDEX  AREAS,  AND  BOTTOM  DEPTH  INFOR- 
TION  AS  INPUTS  TO  THE  SIMAS  PROGRAM. 

INPUTS:  HARD  COPY  SELECTION,  OPERATOR  SELECTION  TO  UPDATE 
PARAMETERS  OR  NOT.  VARIABLES  IN  COMMONS. 

OUTPUTS:  CRT  PROMPTING  MESSAGES  TO  OPERATOR 

MODULES  CALLED:  CRUNCH, ERRSET , ERRTST , FLOOR, FSETUP, GRAPH, HRDCPY, INDX, 

SETOAC , SETPOS 
CALLED  BY:  ENVIRN,  FORCST 
NOTE:  MAP  PROGRAM  REV  C 

NOTE: 

FORMULAS  DEFINING  MERCATOR  PROJECTION  ARE: 

DISTANCE  PER  DEGREE  LAT=  ERAD*PI/180*COS ( CENTER  LATITUDE) 
DISTANCE  PER  DEGREE  LNG=  ERAD*PI/180 

RATIO  OF  THE  GRAPH'S  HEIGHT  TO  WIDTH=1 /COS  (CENTER  LATITUDE) 
TO  REDUCE  EXECUTION  TIME,  LINEAR  FACTORS  WILL  BE  DISREGARDED, 
SO  X  IS  GRAPHED  IN  FIFTIETHS  OF  A  DEGREE  FROM  THE  BASE 
LONGITUDE,  AND  Y  IS  GRAPHED  AS  THE  TANGENT  OF  THE  LATITUDE. 


INCLUDE  'MAP. PAR' 

1  PARAMETER  STOLEN=3800 

1  PARAMETER  SEGLEN=60 ,  P0LLEN=40 

1  PARAMETER  WRKLEN=1000,  NDXLEN=300 

1  PARAMETER  MAXDTY=3 

1  PARAMETER  TOL=3 

1  PARAMETER  DEG=57 . 2957795  • 

1  PARAMETER  RAD= . 017453293 

1  PARAMETER  PI=3 . 14159265 

1  PARAMETER  ERAD=3440.3 

1  PARAMETER  S251=63001 

1  PARAMETER  TW015=327S8 

1 

1  !  INTEGER* 2  MAXDTY , NDXLEN , POLLEN, SEGLEN, STOLEN, TOL,WRKLEN 

1  !  INTEGER* 4  S251,TW015 

1  !  REAL* 4  DEG, ER AD, PI, RAD 

INCLUDE  ' CBC1 . INC ' 

1  !  - CBC1.INC - 


1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 


1  !  BCOORD  (-12:12,2)  7 


1  1 

1  INTEGER* 2  BCOORD ( -12 : 12 , 2 ) 

1 

1  COMMON  /CBC/  BCOORD 

1  ! - END  CBC1.INC 

1 

INCLUDE  ' CBT. INC ' 
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0074 

0075 

0076 
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T 
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0090 
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0100 

0101 
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0104 

0105 


0106 

0107 
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1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 


i  - CBT.INC - 

!  VARBL  SIZE  PURPOSE  TYPE  RANGE 

!  BTRANS  (4,4)  7 

INTEGER* 2  BTRANS (4, 4) 

COMMON  /CBT/  BTRANS 

i - END  CBT.INC - 

INCLUDE  ' CFILE. INC ' 

I  - CFILE.  INC - 

!  VARBL  SIZE  PURPOSE  TYPE  RANGE 

!  FNAME  (21)  MAP  FILE  NAME  CHAR 

!  OPEN  OPEN  FLAG  LOGICAL* 1  .FALSE. 

i 

LOGICAL* 1  OPEN 
CHARACTER* 1  FNAME (21) 

COMMON  /CFILE/  OPEN, FNAME 

i - END  CFILE. INC - 


INCLUDE  'CL. INC' 
VARBL  SIZE  PURPOSE 


■CL.  INC 


TYPE  RANGE 


LATMAX 

LATMIN 

LNGMAX 

LNGMIN 


MAXIMUM  LATIITUDE 
MINIMUM  LATIITUDE 
MAXIMUM  LONGITUDE 
MINIMUM  LONGITUDE 


INTEGER*  2 
INTEGER*  2 
INTEGER* 2 
INTEGER* 2 


INTEGER* 2  LATMIN , LATMAX , LNGMIN , LNGMAX 


COMMON  /CL/  LATMIN, LATMAX, LNGMIN, LNGMAX 
- END  CL. INC - 


INCLUDE  ' CLOC. INC 


VARBL  SIZE  PURPOSE 


CLOC . INC 


TYPE  RANGE 


BLAT 

BLNG 

LAT 

LNG 

NMLT50 

NMT.G5Q 


BASE  LATITUDE  REAL*4 

BASE  LONGITUDE  REAL* 4 

LATITUDE  OF  SHIP'S  LOCATION  REAL*4 

LONGITUDE  OF  SHIP'S  LOCATION  REAL *4 

#  OF  NAUTICAL  MILES  PER  50TH  DEGREE  REAL*4 

OF  LATITUDE 

OF  NAUTICAL  MILES  PER  50TH  DEGREE  REAL*4 

OF  LONGITUDE 


REAL*  4  LAT , LNG , BLAT , BLNG , NMLT5 0  ,  NMLG5 0 


COMMON  /CLOC/  LAT, LNG , BLAT, BLNG, NMLT50 ,NMLG 50 

i - END  CLOC. INC - 

INCLUDE  'CLOG. INC' 

i  - CLOG.  INC - 

!  VARBL  SIZE  PURPOSE  TYPE  RANGE 


c  -39.  a. 
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MAP 


0115 
01 16 

h 

0118 

0119 

017.0 

0121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

M 

0145 
0146 
0147 
0148 
0149 
0150 
0151 
0152 
0153 
0154 
0155 
0156 
0157 
0158 
0159 
0160 
0161 
0162 
0163 
0164 
0165 
0166 
0167 
0168 
0169 
01  70 
>1 


1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 


CNVRT(-lsO) 

DG 

DL 

BYTE  CNVRT(-lsO) ,DG,DL 
COMMON  /CLOG/  CNVRT , DL , DG 

- END  CLOG. INC - 

INCLUDE  ' CNAME. INC ' 

- CNAME. INC - 

VARBL  SIZE  PURPOSE  TYPE  RANGE 


OAC 

ONAME  (25)  OCEAN  NAME 

DNAME  ()  'MGS' ,  'SSP',  OR  'BDEPTH'  TEXT  STRINGS 

INTEGER* 4  ONAME( 25) ,DNAME( 2*MAXDTY) 

INTEGER* 2  OAC 

COMMON  /CNAME/  ONAME , DNAME , OAC 
- END  CNAME. INC - 


INCLUDE  ' CS . INC ' 
VARBL  SIZE  PURPOSE 


-CS- 


TYPE  RANGE 


S  -1,3800  POLYGON  AND  SEGMENT  STORAGE  ARRAY  REAL*4 

STOLEN  STORAGE  ARRAY  LENGTH  (FOR  SEGS  &  POLYS)  PARM 

REAL* 4  S(-l: STOLEN) 

COMMON  /CS/  S 


-CS-END- 


INCLUDE  ' CTSK . INC ' 

- CTSK. INC - 

VARBL  SIZE  PURPOSE  TYPE  RANGE 


TBDPTH 

TFLG 

TLAT  (3) 

TLNG  ( 3 ) 

TMGS 

TOAC 

TSSP 

REAL* 4  TMGS, TSSP, TBDPTH 

INTEGER*  2  TFLG , TOAC ,TLAT ( 3 ) , TLNG ( 3 ) 

COMMON  /CTSK/  TFLG, TOAC, TLAT, TLNG, TMGS , TSSP, TBDPTH 
- END  CTSK. INC - 


INCLUDE  'ENVN. INC ' 

! - ENVN - 

!  VARBL  SIZE  PURPOSE  TYPE  RANGE 


c  -37. 3 


0181 
0182 
0183 
0184 
0 1R5 
0186 
0187 
0188 
0189 
0190 
0191 
0192 
0193 
0194 
0195 
0196 
0197 
0198 
0199 
'  ^00 


MAP 

0172 

1  l 

BIO 

(2) 

BIOLOGICAL  BACK  SCATTERING 

REAL*4 

r  -r3 

1  1 

DLYR 

LAYER  DEPTH 

REAL*4 

.  74 

1  ! 

MGS 

MGS  PROVINCE 

INTEGER* 2 

0175 

1 

0176 

1 

REAL* 4 

BIO, DLYR 

0177 

1 

INTEGER* 2  MGS 

0178 

1 

DATA  BIO/ -57 . ,-47. / 

0179 

1 

0180 

1 

COMMON 

/ENVN/  BIO( 2) , DLYR, MGS 
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-57.  &  -47. 


1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 


-END  ENVN- 


INCLUDE  ' MAPLOC. INC ' 


-MAPLOC- 


VARBL  SIZE 


PURPOSE 


MPINDX 

MAPLAT 

LONG 

NMAREA 

NOC 

RCZ 


(4) 

(4) 

(20) 


SSP  INDEX 

LATITUDE 

LONGITUDE 

AREA  OCEAN  NAME 

NUMBER  OF  OCEAN 

RANGE  TO  CONVERG. 


TYPE 

INTEGER* 2 
INTEGER* 2 
INTEGER*2 
BYTE 

INTEGER* 2 
ZONE  REAL*4 


RANGE 


REAL* 4  RCZ 

INTEGER* 2  MPINDX, MAPLAT, LONG, NOC 
BYTE  NMAREA( 20 ) 

COMMON  /LOC/  MAPLAT(4) ,L0NG(4) , NOC , MPINDX, RCZ , NMAREA 


-END  MAPLOC- 


INCLUDE  'MAFSVP. INC' 


0203 

0204 

1 

1 

i 

l 

VARBL 

SIZE 

PURPOSE 

TYPE 

RANGE 

0205 

1 

i 

BDF 

BOTTOM  DEPTH  IN  FATHOMS 

REAL*4 

0206 

1 

i 

BIOP 

BIOLOGICAL  BACK  SCATTERING  COEF 

REAL*4 

0207 

1 

i 

BTDATE 

(9) 

DATE  OF  LAST  BT  INPUT 

BYTE 

0208 

1 

i 

BTTIME 

(B) 

TIME  OF  LAST  BT  INPUT 

BYTE 

0209 

1 

i 

C 

(50) 

VELOCITY  (PAIRED  WITH  Z  FOR  SVP) 

REAL*4 

0210 

1 

i 

CC 

(50) 

VELOCITY  (PAIRED  WITH  ZZ  FOR  SVP)REAL*4 

0211 

1 

t 

cs 

SOUND  VELOCITY  AT  SURFACE 

REAL*4 

0212 

1 

i 

MAPDEG 

TEMPERATURE  (DEG) 

REAL*4 

57.2957795 

0213 

1 

i 

EL 

LAYER  DEPTH 

DATA 

0214 

1 

i 

F 

FREQUENCY 

REAL*4 

0215 

1 

i 

GRDS 

GRIDS 

REAL*4 

0.0164 

0216 

1 

i 

ITO 

MINIMAL  2 -WAY  TRAVEL  TIME 

INTEGER* 2 

0217 

1 

i 

MGS  OP 

MGS  PROVINCE  NUMBER 

INTEGER* 2 

0213 

1 

i 

N 

#  OF  DEPTH/VELOCITY  PAIRS 

INTEGER* 2 

0219 

1 

i 

NN 

#  OF  DEPTH /VELOCITY  PAIRS 

INTEGER* 2 

0220 

1 

i 

MAPPI 

MATHEMATICAL  CONSTANT  PI 

REAL*4 

3.1415927 

0221 

1 

i 

SNDATE 

(9) 

DATE  SYS  PARMS  LAST  UPDATED 

BYTE 

0222 

1 

i 

SNTIME 

(3) 

TIME  SYS  PARMS  LAST  UPDTAED 

BYTE 

0223 

1 

i 

SYDATE 

(9) 

CURRENT  DATE  READ  FROM  SYSTEM 

BYTE 

0224 

1 

i 

SYTIME 

(8) 

CURRENT  TIME  READ  FROM  SYSTEM 

BYTE 

0225 

1 

i 

TMP 

TEMPERATURE 

REAL* 4 

0226 

1 

i 

UMKZ 

BOTTOM  BACK  SCATTERING  COEF. 

REAL*4 

i 

to 

CO 

» 

o 

r  27 

1 

i 

ws 

WIND  SPEED 

REAL*4 

x.  is 

1 

i 

z 

(50) 

DEPTH  OF  POINT  OF  SOUND  SPEED 

REAL* 4 

C-37.V 
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0229 


0232 

0233 

0234 

0235 

0236 

0237 

0238 

0239 

0240 

0241 

0242 

0243 

0244 

0245 

0246 

0247 

0248 

0249 

0250 

0251 

0252 

0253 

0254 

0255 

0256 

0757 

Ju 

0259 

0260 

0261 

0262 

0263 

0264 

0265 

0266 

0267 

0268 

0269 

0270 

0271 

0272 

0273 

0274 

0275 

0276 

0277 

0278 

0279 

0280 

0281 

0282 

0283 


O'5  84 
i  )5 


1  !  ZZ 
1 
1 
1 
1 
1 
1 
1 
1 
1 
1 
1 
1 

1  I  — 


1 

2 


(50)  DEPTH  OF  POINT  OF  SOUND  SPEED  REAL* 4 
INTEGER* 2  ITO ,MGSOF ,N,NN 

REAL*4  BDF,BIOF,C( 50 ) ,CC(50) , CS , MAPDEG , EL , F , GRDS 

REAL *4  MAPPI ,TMP ,UMKZ ,WS , Z ( 50 ) ,ZZ ( 50 ) 

BYTE  SYDATE ( 9 ) ,SYTIME(8) , BTDATE ( 9 ) , BTTIME( 8) 

BYTE  SNDATE ( 9 ) , SNTIME ( 8 ) 

DATA  MAPPI, MAPDEG, GRDS/ 3. 1415927, 57. 2957795 ,0.0164/ 

DATA  UMKZ/-28 . / 

COMMON  /SVP/  F,N,Z,C,EL,MGSOP,BDF,WS,CS,TMF,BIOF, 

UMKZ , MAPPI , MAPDEG , GRDS , ITO , ZZ , CC , NN , 

SYDATE , SYTIME , BTDATE , BTTIME , SNDATE , SNTIME 
- MAP SVP -END - 


VARBL 

SIZE 

PURPOSE 

TYPE  RANGE 

DEAST 

DISPLAY  SHIFT  FLAG:  EAST 

BYTE 

DELIM 

(6) 

DATA  TYPE  DELIMITER 

REAL*  4 

DNORTH 

DISPLAY  SHIFT  FLAG:  NORTH 

BYTE 

DSOUTH 

DISPLAY  SHIFT  FLAG:  SOUTH 

BYTE 

DTYFE 

DATA  TYPE  LOOP  COUNTER 

INNTEGER*2 

DWEST 

DISPLAY  SHIFT  FLAG:  WEST 

BYTE 

ERR 

ERROR  TEST  FLAG 

INTEGER* 2 

FLOOR 

FUNCTION 

INTEGER* 2 

I 

LOOP  COUNTER 

INTEGER* 2 

INFO 

(3) 

MGS,  SSP,  BDEFTH  INFO 

REAL* 4 

ILAT 

LATITUDE 

INTEGER* 2 

ILNG 

LONGITUDE 

INTEGER* 2 

INDX 

FUNCTION 

INTEGER* 2 

IX 

(4) 

BASE  X  COORD  OF  4  QUADRANTS 

INTEGER* 2 

IY 

(4) 

BASE  Y  COORD  OF  4  QUADRANTS 

INTEGER* 2 

MAPFLG 

MAP  FLAG 

INTEGER* 2 

MEAST 

EAST  ADJUSTMENT 

BYTE 

MNORTH 

NORTH  ADJUSTMENT 

BYTE 

MSQUTH 

SOUTH  ADJUSTMENT 

BYTE 

MWEST 

WEST  ADJUSTMENT 

BYTE 

NEW 

DATA  TYPE  DELIMITER 

REAL* 4 

R 

PROGRAM  FLAG 

BYTE 

RECNDX 

(300) 

RECORD  INDEX 

INTEGER* 2 

SHIFT 

LATITUDE  OR  LONGITUDE  SHIFT 

BYTE 

***  VARIABLES  NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMONS  *** 


REAL*4  DELIM(2*MAXDTY) , INFO ( MAXDTY) ,NEW 

INTEGER* 2  DTYFE , ERR , FLOOR , I , ILAT , ILNG , INDX , IX ( 4 ) ,IY(4) 

INTEGER* 2  MAPFLG , RECNDX ( NDXLEN ) 

BYTE  DEAST ,  DNORTH ,  DSQUTH  ,  DWEST ,  MEAST ,  MNORTH 

BYTE  MSOUTH,MWEST,R, SHIFT 

EQUIVALENCE  (INFO(l) ,TMGS) ,(INF0(2) ,TSSP) ,(INF0(3) , TBDFTH ) 
DATA  DELIM  /l. ,9. ,1. ,99. ,0.,5500./ 


DATA  BCOORD  / 0 , 5 , 10 , 0 , 5 , 10 , 3*5 , 3*10 , 0 , 3*5 , 3*0 , 10 , 5 , 0 , 10 , 

5,0,3*10,3*5,10,5,0,10,5,3*0,5,10,0,5,10,3*0,3*5/ 
DATA  BTRANS  /1 ,2  ,4,5 ,7 ,10,8,11 ,-2,-3 ,-5,-6 , -8,-11 ,-9 ,-12/ 
DATA  FNAME  / 11*  '  M'  ,  '  A'  ,  ' P '  ,  '  <9 '  ,  '  S'  ,  '  .  '  ,  '  D'  ,  '  A'  ,  ' T'  ,  '  }  '  ,  '  0  '  / 


c-3 9.  5" 
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0286 


0289 

0290 

0291 

0292 

0293 

0294 

0295 

0296 

0297 

0298 

0299 

0300 

0301 

0302 

0303 

0304 

0305 

0306 

0307 

0308 

0309 

0310 

0311 

0312 

0313 


0316 

0317 

0318 

0319 

0320 

0321 

0322 

0323 

0324 

0325 

0326 

0327 

0328 

0329 

0330 

0331 

0332 

0333 

0334 

0335 

0336 

0337 

0338 

0339 

0340 


1 

2 

3 


DATA 

DATA 

DATA 


DATA 

DATA 

DATA 


OPEN  /.FALSE./ 

CNVRT  /1,0/ 

ONAME  / 'Nort'  , 'h.  Pa'  , ' ciFi'  ,  'c  Oc' ,'ean' , 'Nort'  ,  'h  At'  , 
' lant ' ,'ic  0' , ' cean' , 'Medi' , ' terr ' , 'anea' , 'n  Se ' , 
' a' , ' Indi ' , ' an  O', 'cean','  ','  ' , 'Norw' , ' egia' , 

'n  Se' , 'a' , '  ' / 

DNAME  / ' MGS ' , 0 , ' SSP ' , 0 , ' BDEP ' , ' TH' / 

S  / STOLEN, 0, STOLEN* 0/ 

TFLG  /.TRUE./ 


i 


C 


1 

2 


PRELIMINARIES 


CALL  ERRSET( 29,,. FALSE. ,,. FALSE. ) 
CALL  ERRSET< 39, , .FALSE. ,, .FALSE. ) 
CALL  ERRSET (63,,. FALSE. ,,. FALSE. ) 
CALL  ERRSET( 72,,. FALSE. ,,. FALSE. ) 
CALL  ERRSET ( 75, , .FALSE. ,, .FALSE. ) 
DO  1  I=-12 , 12 

BC00RD( 1,1) =BCOORD( 1,1) *50 
BC00RD(I,2)=BC00RD( I, 2) *50 
CONTINUE 
CALL  SETOAC 
CALL  FSLT'UP  ( RECNDX ,  R ) 

IF  (R)  GOTO  2 
CALL  SETPOS ( 1  ,R ) 

IF  (R)  CALL  EXIT 
IF  (.NOT.  TFLG)  GOTO  50 
CALL  SETPOS ( 2, R) 

IF  (R)  CALL  EXIT 
IF  (.NOT.  TFLG)  GOTO  50 
ILAT=FL00R(LAT/5. ) 
ILNG=FL00R(LNG/5. ) 


NON-EXISTANT  FILE 

FILE  READ  ERROR 

END-OF-FILE  ENCOUNTERED 

FLOATING  POINT  OVERFLOW 

INTEGER* 2  CONVERSION  ERROR 

SET  UP  BORDER  COORDINATES 

INITIALIZE  BORDER  COORDS 

INITIALIZE  BORDER  COORDS 

END  DO  LOOP 

GET  OCEAN  AREA 

SET  UP  FILE  "MAP" ( OAC) "A" 

IF  ERROR  ASK  OAC  AGAIN 

GET  LATITUDE 

IF  ERROR,  STOP  PROGRAM 

GO  TO  TSK  TO  PASS  TO  SIMAS 

GET  LONGITUDE 

IF  ERROR,  STOP  PROGRAM 

GO  TO  TSK  TO  PASS  TO  SIMAS 

SET  SHIP  POSITION: LOWEST  OFFSET  I 

SET  SHIP  POSITION: LOWEST  OFFSET  I 


DO  21  DTYPE=1 ,MAXDTY 
DL= ( DTYFE. LE. 2 ) 
DG= .NOT.DL 
INFO ( DTYPE) =-3 . 

IF 


-MAIN  PROGRAM  LOOP  FOR  THE  3  DATA 
!  CALC,  DISPLAY  DATA  TYPES 
!  SET  FLAG  FOR  POLYGON  DATA 
!  SET  FLAG  FOR  NON-POLYGON  DATA 
I  INFO  FLAG  BEYOND  LEGAL  VALUE 


( RECNDX (INDX(ILAT,ILNG, DTYPE) ) .EQ.-TWOl 5)  GOTO  17  !  ANY  DATA 

!  OFFSETS  FOR  THE  GRAPHICS 
BLAT=FLOATI ( 5*ILAT-5 )  !  BASE  LATITUDE 

BLNG=FLOATI ( 5*ILNG)  !  BASE  LONGITUDE 


ASSUME  SHIP  IN  QUADRANT  1  (TOP  LEFr 
i  SET  Y  COORDINATE 
!  SET  Y  COORDINATE 
1  SET  Y  COORDINATE 
L  SET  Y  COORDINATE 
!  SET1  X  COORDINATE 
!  SET  X  COORDINATE 
!  SET  X  COORDINATE 
!  SET  X  COORDINATE 

SHIFT  THE  GRAPHICS  DISPLAY  ACCORDII 
========================10  SHIP  LOCATION  &  THE  OCEAN  AREA  BOUND AI 

- west  AND  EAST  ADJUSTMENTS - 

MWEST=( (LNG-5) .GE.LNGMIN)  l  WEST  ADJUSTMENT 


IY ( 1 ) =ILAT 
IY( 2) =ILAT 
IY ( 3 ) =ILAT-1 
IY ( 4 ) =ILAT-1 
IX ( 1 ) =ILNG 
IX{ 2 ) =ILNG+1 
IX  (  3  )  =ILNG 
IX{ 4 ) =ILNG+1 


C-39,i 


MAP 


14-Dec-1984  08:35:1? 
14-Dec-1984  08:35:1- 


0343 

0346 

0347 

0348 

0349 

0350 

0351 

0352 

0353 

0354 

0355 

0356 

0357 

0358 

0359 

0360 

0361 

0362 

0363 

0364 

0365 

0366 

0367 

0368 

0369 

0370 

0*71 

h 

0373 
0374 
0375 
0376 
0377 
0378 
0379 
0380 
0381 
0382 
0383 
0384 
0385 
0386 
0387 
0388 
0389 
0390 
0391 
0392 
0393 
0394 
0395 
0396 
0397 
0^98 
i  9 


DWEST=. FALSE.  t  DISPLAY  SHIFT  FLAG:  WEST 

IF  (MWEST)  DWEST= (RECNDX( INDX( ILAT, ILNG-1 ,DTYPE) ) . GT. -TWO 15) 
MEAST® ( (LNG+5) . LT.LNGMAX)  !  EAST  ADJUSTMENT 

DEAST® .FALSE.  !  DISPLAY  SHIFT  FLAG:  EAST 

IF  (MEAST)  DEAST® (RECNDX(INDX( ILAT, I LNG+1 , DTYPE) ) .GT.-TW015) 
SHIFT® ( LNG/ 5-ILNG. LT. . 5 )  1  LATITUDE  SHIFT 


IF  ( DWEST . XOR . DEAST )  SHIFT=DWEST  l  LONGITIUDE  SHIFT 
IF  ( .NOT. (DWEST. OR. DEAST)  .AND.  ( MWEST . XOR . MEAST ) ) 

*  SHIFT=MWEST  !  LONGITUDE  SHIFT 

IF  (.NOT. SHIFT)  GOTO  4  !  NO  SHIFT 

BLNG®BLNG-5.  !  SHIFT  DISPLAY  WEST 

DO  3  1=1,4  !  DO  FOR  FOUR  X  COORDINATES 

IX(I)=IX(I)-1  1  DECREASE  X  COORDINATE 

3  CONTINUE  !  END  DO  LOOP 

t - SOUTH  AND  NORTH  ADJUSTMENTS 

4  MSOUTH® ( LAT-5 . GE . LATMIN )  !  SOUTH  ADJUSTMENT 


DSOUTH®. FALSE.  ‘  DISPLAY  SHIFT  FLAG:  SOUTH 

IF  (MSOUTH)  DSOUTH® (RECNDX( INDX( ILAT- 1 , ILNG , DTYPE ) ) .GT. -TW015) 
MNORTH® ( LAT+5 . LT . LATMAX )  !  NORTH  ADJUSTMENT 

DNORTH®. FALSE.  !  DISPLAY  SHIFT  FLAG:  NORTH 

IF  (MNORTH)  DNORTH® (RECNDX( INDX< ILAT+1 , ILNG, DTYPE) ) .GT. -TW015) 
SHIFT=(LAT/5-ILAT.GE. .5)  !  LATITUDE  SHIFT 

IF  (DNORTH. XOR. DSOUTH)  SHIFT=DNORTH  >  LONGITUDE  SHIFT 


IF  ( .NOT. (DNORTH. OR. DSOUTH)  .AND.  ( MNORTH. XOR. MSOUTH ) ) 

*  SHIFT® MNORTH  I  LONGITUDE  SHIFT 

IF  (.NOT. SHIFT)  GOTO  6  l  NO  SHIFT,  SKIP 

BLAT=BLAT+5.  !  SHIFT  DISPLAY  NORTH 

DO  5  1=1,4  !  DO  FOR  FOUR  Y  COORDINATES 

IY ( I ) =IY( I ) +1  !  INCREASE  Y  COORDINATES 

5  CONTINUE  l  END  DO  LOOP 

I - ADJUST  SHIP'S  LOCATION - 

6  NMLT50=ERAD*PI/ ( 50 . *180 . )  !  #  NAUTICAL  MILES/50TH  DEG  LAT 

NMLG50=NMLT50*C0S( (BLAT+5. ) API/ 180. ) l  #  NAUTICAL  MILES/ 50TH  DEG  I 
LAT=50.*(LAT-BLAT)  !  SET  UNITS  FOR  SHIP  LOCATION 

LNG® 50 . * ( LNG-BLNG )  !  SHIP  LOCATION 


l - PROCESS  DATA  FOR  THE  10  DEGREE  SQUARE--- 

INFO ( DTYPE ) = - 2 .  1  RESET  FLAG  (DATA  NOT  PROCSSED) 

WRITE ( 5,7)  DNAME(DTYPE*2-1) , DNAME ( DTYPE* 2 )  !  ANALYZING  DATA  MSG 
C  CALL  ERRTST (75, ERR )  !  RESET  FLAG  FOR  INTEGER* 2  OVERFLOt 

CALL  CRUNCH (RECNDX, INFO ( DTYPE ), DTYPE, I Y, IX, R)  !  PROCESS  DATA 
C  CALL  ERRTST (7 5, ERR)  !  FLAG  FOR  INTEGER*2  OVERFLOW 

i -  - DISPLAY  DATA  (IF  DESIRED) - 

WRITE (5,10001)  !  BELL  PROMPT 

IF  (DG)  WRITE ( 5,10002)  i  ERASE  THE  WHOLE  SCREEN 

IF  ((DG)  .OR.  (R)  .OR.  (ERR- 2) )  GOTO  8  1  SKIP  GRAPHICS 
CALL  GRAPH (DTYPE)  !  DISPLAY  GRAPHICS 

8  WRITE (5,10001)  !  PROMPT  BELL 

IF  (DG)  TYPE  *, 'BOTTOM  DEPTH  IS  IN  FATHOMS'  !  IF  BOTTOM  DEPTH 
WRITE ( 5,9)  DNAME ( DTYPE*2 - 1 ) , DNAME ( DTYPE* 2 ) , INT( INFO ( DTYPE) ) 

10  READ( 5,10003)  NEW  1  NEW  CURRENT  DATA  TYPE 

IF  (NEW.NE.O.)  INFO ( DTYPE )=NEW l  NEW  DATA  TYPE 

IF  (INFO(DTYPE) .GE.DELIM(DTYPE*2-1)  !  VALID,  SKIP  NEXT 
*  .AND.  INFO ( DTYPE ) . LE.DELIMv DTYPE*2 ) )  GOTO  12  !  SKIP  NEXT 


C-3'7.'? 


MAP 


0400 


0403 

0404 

0405 

0406 

0407 

0408 

0409 

0410 

0411 

0412 

0413 

0414 

0415 

0416 

0417 

0418 

0419 

0420 

0421 

0422 

0423 

0424 

0425 

0426 

0427 


0430 

0431 

0432 

0433 

0434 

0435 

0436 

0437 

0438 

0439 

0440 

0441 

0442 

0443 

0444 

0445 

0446 


12 

17 

19 


21 


25 


50 

999 


14-Dec-1984  08i35:l 
14-Dec-1984  08:35:1 


WRITE( 5,11)  DNAME (DTYPE* 2-1) , DNAME ( DTYPE* 2 ) , 
INT(DELIM(DTYFE*2-1) ) , INT( DELIM( DTYPE*2 ) ) 


!  PROMPT  OPERATOR 
!  FOR  VALID 


GOTO  10 

IF  (.NOT.DG)  CALL  HRDCFY 
WRITE( 5,10002) 

LAT=LAT/ 50 . +BLAT 
LNG=LNG/ 50 . +BLNG 
GOTO  21 

WRITE ( 5 , 1 8 ) DNAME ( DTYPE* 2 - 1 ) 


INVALID,  TRY  AGAIN 
NON-POLYGON  DATA  FLAG 
CLEAR  SCREEN 
LOCATION  IN  DEGREES 
LOCATION  IN  DEGREES 
DO  NEXT  DATA  TYPE 
PROMPT  FOR  NEW  VALUE 


DNAME (DTYPE* 2) ,INT(DELIM(DTYPE*2-1) ) ,INT(DELIM(DTYPE*2) ) 
READ(5, 10003)  NEW  l  NEW  VALUE 

INFO ( DTYPE )=NEW  !  STORE  NEW  VALUE 

IF  ( INFO ( DTYPE ) .GE.DELIM(DTYFE*2-1) !  VALID 

.AND.  INFO ( DTYPE ) .LE. DEL IM(DTYPE*2) )  GOTO  21 


WRITE( 5,20 ) 

GOTO  19 
CONTINUE 
NOC=OAC 
BDF = INFO ( 3 ) 

MGS  =  I IFIX ( INFO ( 1 ) ) 

MGSOP=MGS 

MPINDX=IIFIX( INFO ( 2 ) ) 

DO  25  1=1,3 

MAPLAT ( I ) = I ABS ( TLAT ( I ) ) 

LONG( I ) =IABS (TLNG( I ) ) 
CONTINUE 
MAPLAT ( 4 ) = ' N ' 

IF ( TLAT ( 1 ) . LT . 0 )  MAPLAT ( 4 )  =  '  S ' 
L0NG(4)='E' 

IF ( TLNG( 1 ) . LT . 0 )  L0NG(4)='W' 
GOTO  999 
MAPFLG=. FALSE. 

RETURN 


IN  FATHOMS 

NUMBER 

NUMBER 


INVALID  WARNING 
TRY  AGAIN 
END  DO  LOOP 
OCEAN  NUMBER 
BOTTOM  DEPTH 
MGS  PROVINCE 
MGS  PROVINCE 
SSP  INDEX 
DO  3  TTMF.S 
LATITUDE 
LONGITUDE 
END  DO  LOOP 
LATITUDE 
LATITUDE 
LONGITUDE 
LONGITUDE 

RETURN  TO  CALLING  ROUTINE 
SET  MAP  FLAG  TO  FALSE 
RETURN  TO  CALLING  ROUTINE 


i  - 

7 

9 


-FORMAT  STATEMENTS - 

FORMAT ( / 2 6X , ' *  ANALYZING  ' , 2A4 , '  DATA  *') 

FORMAT(X, 'THE  ',2A4,'  VALUE  IS  ',15,/ 

X,' ENTER  NEW  VALUE  (RETURN  KEEPS  CURRENT  VALUE) 
2A4 , '  VALUE  MIN=',I2,'  MAX='I4,/, 


'$) 


11 

FORMAT(X, ' INVALID 

* 

X,  'RE 

18 

FORMAT (X, 'DATA  BAS) 

* 

/ ,X, 'MIN= 

20 

FORMAT ( X , ' INVALID  ’ 

10001 

FORMAT (X, ' ! BEL ' ) 

10002 

FORMAT (X, ' ! WOR  0' ) 

10003 

FORMAT (F9.0) 

END 

ENTER  VALUE  '  ,  $ ) 


,$) 


4025  BELL  PROMPT 

4025  SCREEN  ERASE 

FLOATING  DECIMAL  POINT  FORMAT 


03?.^ 


0001 

SUBROUTINE  METRIC ( INSSP , D, T , NBT , Z , C , 

SLNTY 

,VS1, IERROR) 

0002 

>003 

!  PROLOGUE: 

0004 

!  MODULE 

NAME:  METRIC 

0005 

!  AUTHOR 

:  S.  LAFLEUR  &  W.  WACHTER,  CODE  3333 

,  NUSC/NLL 

0006 

!  DATE: 

1983  &  12/83  (FORTRAN  77) 

0007 

!  FUNCTION:  SUBROUTINE  METRIC  PRODUCES  DEPTH 

,  TEMPERATURE, 

0008 

; 

AND  SOUND  SPEED  IN  ENGLISH  UNITS 

FROM 

INPUT  DEPTH, 

0009 

i 

TEMPERATURE,  AND/OR  SOUND  SPEED 

ENTERED  IN  ENGLISH 

0010 

i 

OR  METRIC  UNITS. 

0011 

!  INPUTS 

:  PARAMETERS  PASSED  IN. 

0012 

!  OUTPUTS:  PARAMETERS  PASSED  OUT. 

0013 

!  MODULES  CALLED:  LEROY, VELTMP 

0014 

!  CALLED 

BY:  BT , XBTERR 

0015 

; 

0016 

!  VARBL 

SIZE  PURPOSE 

TYPE  RANGE 

n  n  i  7 

|  . 

u  u  x  / 

0018 

!  C 

(1)  VELOCITY 

REAL *4 

0019 

!  D 

( 1 )  DEPTH 

REAL *4 

0020 

!  FACTOR 

CONSTANT  FACTOR 

REAL *4  .3048006 

0021 

!  I 

COUNTER 

INTEGER* 2 

0022 

!  I ERROR 

ERROR  IN  DATA  INPUT  FLAG 

INTEGER* 2 

0023 

!  INSSP 

TYPE  OF  SSP  SELECTED 

INTEGER* 2 

0024 

!  NBT 

NUMBER  OF  BT  POINTS 

INTEGER* 2 

0025 

!  SLNTY 

SALINITY 

REAL *4 

0026 

!  T 

( 1 )  TEMPERATURE 

REAL *4 

0027 

!  VS1 

VELOCITY 

REAL *4 

0028 

!  Z 

( 1 )  DEPTH 

REAL *4 

0029 

i 

• 

J030 

INTEGER* 2  I , IERROR, INSSP, NBT 

0031 

REAL *4  C,D, SLNTY, T,VS1,Z 

0032 

0033 

DIMENSION  D(l) ,T(1) ,Z(1) ,C(1) 

0034 

PARAMETER  FACTOR  =  .3048006 

0035 

0036 

DO  100  I  =  1 ,  NBT 

; 

DO  FOR  NUMBER  OF  BT 

0037 

IF(T(I) .LE.25. )  THEN 

| 

CASE  =<25 

0038 

D ( I ) =D ( I ) /FACTOR 

i 

• 

METRIC  TEMP 

0039 

T(l)=1.8*T(I)+32. 

; 

CONVERT  TO  ENGLISH 

0040 

Z(I)-D(I) 

! 

DEPTH 

0041 

CALL  LEROY ( D ( I ) , T ( I ) , SLNTY , C (  I )  ) 

i 

CONVERT  TEMP  TO  SS 

0042 

GO  TO  100 

f 

NEXT  I 

0043 

END  IF 

; 

END  IF  BLOCK 

0044 

I F ( T ( I ) . GT . 2 5 . . AND ,T(l).LE.38.)  THEN  ! 

CASE  >25  TO  <=38 

0045 

IF ( VS1 .GE .4900.)  THEN 

! 

• 

DATA  IS  ENGLISH  TEMP 

0046 

D ( I ) =D ( I ) /FACTOR 

! 

DATA  IS  METRIC  TEMP 

0047 

T ( I ) =1 . 8 *T( I )  +  32  . 

1 

* 

TEMPERATURE 

0048 

END  IF 

1 

END  IF 

0049 

Z( I)-D(I) 

1 

• 

DEPTH 

0050 

CALL  LEROY ( D ( I ) , T ( I ) , SLNTY , C ( I ) ) 

1 

CONVERT  TEMP  TO  SS 

0051 

GO  TO  100 

! 

NEXT  I 

0052 

END  IF 

| 

END  IF  BLOCK 

0053 

I F ( T ( I ) . GT .38.. AND ,T(l).LE.100.)  THEN  ! 

CASE  >38  TO  <=100 

0054 

Z(I)«D( I) 

1 

DEPTH 

0055 

CALL  LEROY ( D ( I ) , T ( I ) , SLNTY , C ( I ) ) 

1 

CONVERT  TEMP  TO  SS 

0056 

GO  TO  100 

! 

NEXT  I 

;057 

END  IF 

I 

• 

END  IF  BLOCK 

0058 

I F ( T ( I ) .GE.1430. , AND . T ( I ) .LE.1600. 

)  THEN  !  CASE  >=1430  TO  <= 

0059 

D( I ) =D( I ) /FACTOR 

i 

• 

METRIC  SOUND  SPEED 

0  35\f 


0060 

0061 

1)062 

0063 

0064 

0065 

.. 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

100 

0078 

999 

0079 

0Q80 

1 - 

0081 

10 

0082 

0083 

0084 

0085 

0086 

20 

0087 

Z(l)=D(l) 

t(i  )=t(  D/factor 

C { I ) =T (  I ) 

I F ( INSSP.NE. 5 )  CALL  VELTMP ( 
GO  TO  100 
END  IF 

IF(T( I) .GE.4700. .AND.T(I) .LE. 

Z ( I ) =D( I ) 

C( I )=T( I ) 

IF ( INSSP.NE. 5)  CALL  VELTMP ( 
GO  TO  100 
END  IF 

WRITE (5,10)  I,D(I),T(I) 

READ (5,20)  I ERROR 
I ERROR  =  1 
GO  TO  999 
CONTINUE 
RETURN 


!  DEPTH 
!  TEMPERATURE 
!  VELOCITY 

D(I),C(I),T(I), SLNTY )  !  SSP  NOT  5 
!  NEXT  I 
!  END  ID  BLOCK 

5250.)  THEN  !  CASE  >=4700  TO  <=52 
ENGLISH  SOUND  SPEED 
DEPTH 
VELOCITY 

D(l),C(I),T(I), SLNTY )  !  SSP  NOT  5 
NEXT  I 

END  IF  BLOCK 
DATA  POINT  OUT  OF  RANG 
RE-ENTER  PROFILE 
ERROR  FLAG  SET 
RETURN  TO  CALLING  ROUT 
END  DO  LOOP 

RETURN  TO  CALLING  ROUT 


FORMAT  STATEMENT - 

FORMAT ( 1  DATA  POINT  OUT  OF  RANGE  IN  ''SUBROUTINE  METRIC  ' ' // 

1  15 , 2F7 . 2// 

2  '  PLEASE  RE-ENTER  THE  PROFILE'/ 

3  '  OR  USE  LAST  PROFILE  AND  EDIT  THIS  POINT'/////// 

4  •  ****  hiT  RETURN  ****', T45r$) 

FORMAT ( 15) 

END  !  END  SUBROUTINE 


C-3>*.  2. 


0001  SUBROUTINE  MOVE ( NEWX , NEWY ) 

0002 

|)003  !  PROLOGUE: 

0004  !  MODULE  NAME:  MOVE 

0005  !  AUTHOR:  J.  CASCIO,  W.  WACHTER ( FORTRAN  77),  NUSC/NL,  CODE  3333 

0006  !  DATE:  1981  &  9/84  (FORTRAN  77) 

0007  !  FUNCTION:  MOVES  A  VECTOR  FROM  THE  CURRENT  POSITION  KBEAMX , KBEAMY 

0008  !  TO  NEWX, NEWY 

0009  !  INPUTS:  COORDINATED  TO  MOVE  TO 

0010  !  OUTPUTS:  MOVED  BEAM 

0011  !  MODULES  CALLED:  NONE 

0012  !  CALLED  BY:  AXIS,  BOX,  GRID,  MOVEU,  STRING,  SVPGRF 

0013  ! 

0014  INCLUDE  'TK4025.INC' 

0015  1  ! - TK4025 - 

0016  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0017  1  ! -  -  -  - 

0018  1  !  KBEAMX  CURRENT  BEAM  X  POSITION  INTEGER* 2 

0019  1  !  KBEAMY  CURRENT  BEAM  Y  POSITION  INTEGER*2 

0020  1 

0021  1  INTEGER*2  KBEAMX , KBEAMY 

0022  1 

0023  1  COMMON/TK402 5 /KBEAMX, KBEAMY 

0024  1  ! - TK4025  END - 

0025  ! 

0026  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0027  !  - -  -  - 

0028  !  NEWX  X  RASTER  COORD  OF  CURRENT  BEAM  POSITION  INTEGER *2 

0029  !  NEWY  Y  RASTER  COORD  OF  CURRENT  BEAM  POSITION  INTEGER* 2 

)030  ! 

0031  INTEGER* 2  NEWX, NEWY 

0032 

0033  KBEAMX=NEWX  !  X  COORD  OF  CURRENT  BEAM  POSITION 

0034  KBEAMY=NEWY  !  Y  COORD  OF  CURRENT  BEAM  POSITION 

0035  WRITE( 5,1)  KBEAMX, KBEAMY  !  MOVE  BEAM 

0036  RETURN  !  RETURN  TO  CALLING  ROUTINE 

0037 

0038  ! - FORMAT  STATEMENT - 

0039  1  FORMAT ( *  ! VEC  ',215) 

0040  END 


c-z'u 


0001 

0002 

1)003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 

0011 

0012 

0013 

0014 

0015 


0051 
0052 
0053 
0054 
0055 
'1056 
A)  57 
0058 
0059 


SUBROUTINE  NOCONV ( RRR , LYR ) 

PROLOGUE : 

MODULE  NAME:  NOCONV 

AUTHOR:  G.  BROWN  &  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  1974  &  12/83  (FORTRAN  77) 

FUNCTION:  SUBROUTINE  NOCONV  IS  USED  TO  OBTAIN  A  QUICK 

APPROXIMATION  FOR  THE  RANGE  TO  THE  CONVERGENCE  ZONE. 
INPUTS:  VARIABLES  IN  COMMONS. 

OUTPUTS:  PARAMETERS  PASSED  OUT. 

MODULES  CALLED:  ACOUS , INSERT 
CALLED  BY:  ENVIRN , FORCST 


INCLUDE  'S VP. INC' 


-SVP- 


0016 

0017 

1 

1 

! 

i 

VARBL 

SIZE 

PURPOSE 

TYPE 

RANGE 

0018 

1 

; 

BDF 

BOTTOM  DEPTH  IN  FATHOMS 

REAL*4 

0019 

1 

i 

BIOP 

BIOLOGICAL  BACK  SCATTERING  COEF 

REAL *4 

0020 

1 

j 

BTDATE 

(9) 

DATE  OF  LAST  BT  INPUT 

BYTE 

0021 

1 

t 

BTT I ME 

(8) 

TIME  OF  LAST  BT  INPUT 

BYTE 

0022 

1 

i 

C 

(50) 

VELOCITY  (PAIRED  WITH  Z  FOR  SVP) 

REAL *4 

0023 

1 

i 

CC 

(50) 

VELOCITY  (PAIRED  WITH  ZZ  FOR  SVP 

) REAL *4 

0024 

1 

I 

CS 

SOUND  VELOCITY  AT  SURFACE 

REAL *4 

0025 

1 

i 

DEG 

TEMPERATURE  (DEG) 

REAL *4 

57.2957795 

0026 

1 

i 

• 

EL 

LAYER  DEPTH 

DATA 

0027 

1 

i 

• 

F 

FREQUENCY 

REAL *4 

0028 

1 

i 

• 

GRDS 

GRIDS 

REAL *4 

0.0164 

0029 

1 

t 

ITO 

MINIMAL  2-WAY  TRAVEL  TIME 

INTEGER* 2 

J  0  3  0 

1 

j 

MGSOP 

MGS  PROVINCE  NUMBER 

INTEGER* 2 

0031 

1 

! 

N 

#  OF  DEPTH/ VELOCITY  PAIRS 

INTEGER* 2 

0032 

1 

i 

• 

NN 

#  OF  DEPTH/ VELOCITY  PAIRS 

INTEGER* 2 

0033 

1 

i 

PI 

MATHEMATICAL  CONSTANT  PI 

REAL *4 

3.1415927 

0034 

1 

i 

SNDATE 

(9) 

DATE  SYS  PARMS  LAST  UPDATED 

BYTE 

0035 

1 

i 

• 

SNTIME 

(8) 

TIME  SYS  PARMS  LAST  UPDTAED 

BYTE 

0036 

1 

i 

• 

SYDATE 

(9) 

CURRENT  DATE  READ  FROM  SYSTEM 

BYTE 

0037 

1 

i 

SYTIME 

(8) 

CURRENT  TIME  READ  FROM  SYSTEM 

BYTE 

0038 

1 

i 

# 

TMP 

TEMPERATURE 

REAL *4 

0039 

1 

i 

• 

UMKZ 

BOTTOM  BACK  SCATTERING  COEF. 

REAL *4 

-28.0 

0040 

1 

| 

WS 

WIND  SPEED 

REAL *4 

0041 

1 

i 

» 

z 

(50) 

DEPTH  OF  POINT  OF  SOUND  SPEED 

REAL *4 

0042 

1 

j 

zz 

(50) 

DEPTH  OF  POINT  OF  SOUND  SPEED 

REAL *4 

0043 

1 

0044 

1 

INTEGER* 

2  ITO, MGSOP, NrNN 

0045 

1 

REAL* 4 

3DF , BIOP , C( 50 ) , CC( 50 ) ,CS,DEG,EL 

, F , GRDS 

0046 

1 

REAL *4 

PI , TMP , UMKZ , WS , Z ( 50 ) ,ZZ(50) 

0047 

1 

BYTE 

SYDATE ( 9 ) , SYT I ME ( 8 ) , BTDATE ( 9 ) , BTTIME( 8 ) 

0048 

1 

BYTE 

SNDATE ( 9 ) , SNTIME ( 8 ) 

0049 

1 

DATA 

PI , DEG, GRDS/3. 14 15927, 57.2957795,0.0164/ 

0050 

1 

DATA 

UMKZ/- 2 8 ./ 

1 

1 

1 

1 

1 


COMMON  /SVP/  F , N , Z , C , EL , MGSOP , BDF , WS , CS , TMP , B IOP , 

1  UMKZ , PI , DEG , GRDS , ITO, ZZ , CC , NN, 

2  S YD ATE , SYT I ME , BTDATE , BTT I ME , SNDATE , SNTIME 

- SVP-END - 

VARBL  SIZE  PURPOSE  TYPE 

CV  VERTEX  VELOCITY  REAL *4 


RANGE 


0060 

!  DCV 

DIFF  IN  SOUND  SPEED 

REAL *4 

0061 

!  GCZ 

SPREADING  LOSS 

REAL *4 

J062 

!  HCZ 

HORIZONTAL  RANGE  FOR 

SOUND  SPEED  REAL *4 

0063 

!  J 

COUNTER 

INTEGER* 2 

0064 

!  LYR 

SOUND  VELOCITY  PROFILE 

INDEX  INTEGER* 2 

0065 

!  RCZ 

COMPUTATION  OF  RANGE 

TO 

CZ  REAL *4 

0066 

!  RRR 

RANGE  TO  CONVERGENCE 

ZONE  REAL *4 

0067 

!  SCZ 

SLANT  RANGE 

REAL *4 

0068 

!  TCZ 

TRAVEL  TIME 

REAL *4 

0069 

!  TPZ 

TIME-VELOCITY  GRADIENT 

REAL *4 

0070 

!  VEXCS 

VEL  EXCESS  NEEDED  FOR 

EX I STANCE  OF  CZ  REAL *4 

0071 

i 

0072 

!  ***  VARIABLES  NOT  LISTED  HERE  SHOULD 

APPEAR  IN  COMMONS  *** 

0073 

0074 

INTEGER*2  J , LYR 

0075 

REALM  CV, DCV, GCZ, HCZ, RCZ, 

RRR , SCZ , TCZ , TPZ , VEXCS 

0076 

DATA  VEXCS/ 20./ 

0077 

0078 

RCZ=1000000 . 

J 

COMPUTATION  OF  RANGE  TO  CZ 

0079 

IF  (EL.LT.Z(N))  THEN 

; 

LAYER  DEPTH  <  LAST  SVP  DEPTH 

0080 

CALL  I NSERT ( N , Z , C , EL , LYR ) 

f 

INSERT  DEPTH/VEL  PAIR 

0081 

DCV=C(N)-C(LYR) 

j 

SS  AT  BOTTOM  -  AT  LAYER  DEPTH 

0082 

IF  ( DCV. GE. VEXCS)  THEN 

j 

IF  SS  DIFFERENCE  >=  20.0  FT/SEC 

0083 

DCV=DCV/9 . 

f 

GET  1/9  THE  SOUND  SPEED  DIFF 

0084 

CV=C( LYR) -DCV+ . 0 1 

j 

ADJUSTED  SPEED  AT  LAYER 

0085 

DO  500  J=l,10 

i 

• 

DO  TEN  TIMES 

0086 

CV=CV+DCV 

INCREMENT  CV  BY  1/9  SS  DIFF 

0087 

CALL  ACOUS ( Z , C , N , CV , TCZ 

, HCZ, GCZ, SCZ, TPZ)  !  HORIZ  RANGE 

9088 

IF  (HCZ. LE. RCZ)  THEN 

! 

• 

HORIZ  RANGE  <=  RANGE  TO  CZ 

7089 

RCZ=HCZ 

I 

RESET  RANGE  TO  CZ 

0090 

END  IF 

1 

END  IF  BLOCK 

0091 

500 

CONTINUE 

J 

END  DO  LOOP 

0092 

END  IF 

1 

END  IF  BLOCK 

0093 

ELSE 

1 

LAYER  DEPTH  >=  LAST  SVP  DEPTH 

0094 

LYR=N 

J 

SET  LAYER  DEPTH 

0095 

END  IF 

i 

END  IF  BLOCK 

0096 

0097 

RRR=.Q01*RCZ 

i 

RANGE  TO  CZ 

0098 

RETURN 

j 

RETURN  TO  CALLING  ROUTINE 

0099 

END 

i 

END  SUBROUTINE 

C-40.2. 


0001 
0002 
J)  0  0  3 
0004 
0005 
0006 
0007 
0008 
0009 
0010 
0011 
0012 
0013 
0014 
0015 
0016 
0017 
0018 
0019 
0020 
0021 
0022 
0023 
0024 
0025 
0026 
0027 
0028 
0029 
)030 
0031 
0032 
0033 
0034 
0035 
0036 
0037 
0038 
0039 
0040 
0041 
0042 
0043 
0044 
0045 
0046 
0047 
0048 
0049 
0050 
0051 
0052 
0053 
0054 
0055 
0056 
)057 
0058 
0059 


SUBROUTINE  OPNFIL ( FTYPE , R) 


PROLOGUE : 

MODULE  NAME:  OPNFIL 

AUTHOR:  E.  PETR IDES  &  P.  FRAGEORGIA  OF  SYSCON,  INC 

RECODED:  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  1982  &  6/84  (FORTRAN  77) 

FUNCTION:  SUBROUTINE  IS  DESIGNED  TO  OPEN  ALL  FILES  FOR  THE  "MAP" 
PROGRAM.  ALL  FILES  ARE  DIRECT  ACCESS  AND  HAVE  A 
RECORD  SIZE  OF  64  WORDS.  '  ONLY  FILE  NAMES  OF  THE  FORM: 

"MAP"& (OCEAN  AREA  NUMBER) &"A"  OR  "B" 

WILL  BE  OPENED.  ERRORS  IN  OPENING  FILES  WILL  BE 
FLAGGED  AND  EXECUTION  WILL  CONTINUE. 

INPUTS:  NAMES  NEEDED  OF  DATA  FILE  TO  BE  OPENED 
OUTPUTS:  ERROR  FLAG  AND  OPEN  FLAG 
MODULES  CALLED:  NONE 
CALLED  BY:  CRUNCH,  FSETUP 


1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 


INCLUDE  'MAP. PAR' 

PARAMETER  STOLEN=3800 
PARAMETER  SEGLEN=60 ,  POLLEN=40 
PARAMETER  WRKLEN=1000,  NDXLEN=300 
PARAMETER  MAXDTY  = 3 
PARAMETER  TOL=3 
PARAMETER  DEG=57 . 2957795 
PARAMETER  RAD= . 0 17453293 
PARAMETER  PI=3 . 14159265 
PARAMETER  ERAD=3440.3 
PARAMETER  S251=63001 
PARAMETER  TW015=32768 

INTEGER* 2  MAXDTY , NDXLEN , POLLEN , SEGLEN , STOLEN , TOL , WRKLEN 

INTEGER* 4  S251,TW015 

REAL *4  DEG ,ER AD, PI, RAD 

INCLUDE  ' CFILE . INC ' 

- CFILE. INC - 


VARBL 

SIZE 

PURPOSE 

TYPE 

RANGE 

FNAME 

(21) 

MAP  FILE  NAME 

CHAR 

OPEN 

OPEN  FLAG 

LOGICAL*! 

•FALSE 

LOG I CAL *1  OPEN 

CHARACTER* 1  FNAME (21) 

COMMON  /CFILE/  OPEN, FNAME 

- END  CFILE. INC - 

INCLUDE  ' CNAME . INC ' 

- CNAME. INC - 

VARBL  SIZE  PURPOSE  TYPE  RANGE 


OAC 

ONAME  (25)  OCEAN  NAME 

DNAME  ()  'MGS’,  'SSP',  OR  'BDEPTH'  TEXT  STRINGS 

INTEGER* 4  ONAME (25), DNAME ( 2 * MAXDTY ) 

INTEGER* 2  OAC 

COMMON  /CNAME/  ONAME , DNAME , OAC 


C-HM 


END  CNAME . INC 


0060 

0061 

>062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 

0081 

0082 

0083 

0084 

0085 

0086 

0087 

0088 

)089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 

0101 

0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 

0111 

0112 

0113 

0114 

0115 

1116 

0117 

0118 


1 

1 


VARBL  SIZE  PURPOSE 


TYPE  RANGE 


A  'A' 

B  'B' 

FTYPE  DATA  FILE  TYPE 

I  INDEX 

R  ERROR  FLAG 


CHARACTER* 1 
CHARACTER* 1 
LOGICAL 
INTEGER*2 
LOGICAL 


***  VARIABLES  NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMONS  *** 


INTEGER* 2  I 

CHARACTER *1  A , B 
LOG I CAL *1  R, FTYPE 
DATA  A,B/' A' , 'B'/ 

SET  ERROR  FLAG 
SET  OPEN  FLAG 

SET  FILE  NAME  TO  BE  OPENED 
SET  TO  INDEX  FILE 
"B:  DATA  FILES 


R3. FALSE. 

OPEN= . TRUE . 

C  FNAME ( 5 ) =B 

C  IF  (FTYPE)  FNAME ( 5 ) = A 

IF( .NOT. FTYPE)  GOTO  200 


110 

120 

130 

140 

150 


- "A"  DATA  FILES - 

GOTO( 110,120,130,140,150) , OAC  !  GO  TO  FILE  FOR  OEAN  REQUESTE 

GOTO  1  !  ERROR  EXISTS 

OPEN  ( UNIT34 , NAME= 1 MAP1A.DAT; 1 '  , ACCESS3 ' DIRECT '  , RECORDS  I ZE  =  32 , 

READONLY, FORM= ' UNFORMATTED' , TYPE3 'OLD' , ERR=1)  !  OPENN.  A 
GOTO  3  !  GO  TO  RETURN 

OPEN  ( UNIT=4 , NAME3 ' MAP2A . DAT; 1 ' , ACCESS3 ’ DIRECT ' ,RECORDSIZE=32 , 

READONLY , FORM3 ' UNFORMATTED ' , TYPE3 ' OLD ' , ERR3 1 )  !  OPENN.  P 

GOTO  3  !  GO  TO  RETURN 

OPEN  (UNIT3 4 , NAME= ' MAP 3 A . DAT ; 1 ' ,ACCESS= ' DIRECT ' ,RECORDSIZE=32 , 
READONLY, FORM=' UNFORMATTED ' ,TYPE=’ OLD' ,ERR=1)  !  OPEN  MED 

GOTO  3  !  GO  TO  RETURN 

OPEN  ( UNIT=4 , NAME= ' MAP 4 A . DAT ; 1 '  , ACCESS3 ' DIRECT '  , RECORDS  I ZE= 3 2 , 

READONL Y, FORM3' UNFORMATTED ', TYPE3 'OLD' , ERR3 1)  !  OPEN  INDI 

GOTO  3  !  GO  TO  RETURN 

OPEN  ( UNIT=4 , NAME= 1 MAP5 A . DAT ; 1 '  , ACCESS= ' DIRECT '  , RECORDS  I ZE= 32 , 

READONLY , FORM= ' UNFORMATTED ' , TYPE3 ' OLD ' , ERR= 1 )  !  OPEN  NORW 

GOTO  3  !  GO  TO  RETURN 


200 

210 

220 

230 

240 

250 


- "B"  DATA  FILES - 

GOTO(210, 220, 230, 240,250) , OAC  !  GO  TO  FILE  FOR  OCEAN  REQUEST 

GOTO  1  !  ERROR 

OPEN  ( UN I T  =  4 , NAME  = ' MAP 1 B . DAT ; 1 '  , ACCESS3 ' DI RECT ' , RECORDS  I ZE= 3 2 , 

READONLY , FORM3 ' UNFORMATTED ' , TYPE3 ' OLD 1 , ERR= 1 )  !  OPENN.  P 
GOTO  3  !  GO  TO  RETURN 

OPEN  ( UN IT= 4 , NAME3 ' MAP2B . DAT ; 1 ' , ACCESS3 ' DIRECT ' , RECORDS IZE=32 , 

READONLY, FORM3 'UNFORMATTED' , TYPE3' OLD' ,ERR=1)  !  OPENN.  A 

GOTO  3  !  GO  TO  RETURN 

OPEN  ( UNIT= 4 ,NAME= 1 MAP3B . DAT ; 1 ’ , ACCESS3 ’ DIRECT’ , RECORDSIZE=32 , 
READONL Y, FORM3' UNFORMATTED' , TYPE3 'OLD' ,ERR=1)  !  OPEN  MED 

GOTO  3  !  GO  TO  RETURN 

OPEN  ( UNIT=4, NAME3' MAP4B. DAT ; 1 ' , ACCESS3 ' DI RECT ' , RECORDSIZE=32 , 

READONLY, FORM3' UNFORMATTED ', TYPE3 'OLD' ,ERR=1)  !  OPEN  INDI 

GOTO  3  !  GO  TO  RETURN 

OPEN  (UNIT=4, NAME3' MAP5B.DAT;!’ , ACCESS3 ' DIRECT' , RECORDS IZE=3 2 , 


C-Hl.Z. 


0119 

0120 

)121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 


READONLY , FORM= ' UNFORMATTED ' , TYPE= ' OLD ' , ERR= 1 )  !  OPEN  NORW 

GOTO  3  !  GO  TO  RETURN 


1  TYPE  2, (FNAME(I) ,1=1,11) 

WRITE (5,1001) 

READ( 5,1002) 

R- .TRUE. 

OPEN= . FALSE . 

3  RETURN 


ERROR  EXISTS  IN  OPEN  FILE 

WARN  OPERATOR 

PAUSE 

SET  ERROR  FLAG  TO  TRUE 
SET  OPEN  FLAG  TO  FALSE 
RETURN  TO  CALLING  PROGRAM 


! - FORMAT  STATEMENTS - 

2  FORMAT ( ’  ERROR  IN  OPENING  ' ' ' , 11A1 , ' ' ' ,  INOPNFIL') 

1001  FORMAT(23X, 'PAUSE  (HIT  RETURN  TO  CONTINUE) ' $ ) 

1002  FORMATO 
END 


COMMAND  QUALIFIERS 

FORTRAN  /CHECK=ALL/LIST/SHOW=( INCLUDE , NOMAP )  DBA3 : [ L AFLEUR ] OPNF I L . F77 ; 1 

/CHECK3 ( BOUNDS , OVERFLOW , UNDERFLOW ) 

/DEBUG= ( NOSYMBOLS , TRACEBACK ) 

/STANDARD3 ( NOSYNTAX , NOSOURCE_FORM ) 

/ SHOW3 ( NOPREPROCESSOR , INCLUDE , NOMAP ) 

/F77  /NOG  FLOATING  /I4  /OPTIMIZE  /WARNINGS  /NOD  LINES  /NOCROSS  REFERENCE 


COMPILATION  STATISTICS 


Run  Time: 
Elapsed  Time: 
Page  Faults: 
Dynamic  Memory: 


1.69  seconds 
3.25  seconds 
399 

136  pages 


C-^f.3 


0001 
0002 
1)003 
0004 
0005 
0006 
0007 
0008 
0009 
0010 
0011 
0012 
0013 
0014 
0015 
0016 
0017 
0018 
0019 
0020 
0021 
0022 
0023 
0024 
0025 
0026 
0027 
0028 
<3029 
;o3o 
0031 
0032 
0033 
0034 
0035 
0036 
0037 
0038 
0039 
0040 
0041 
0042 
0043 
0044 
0045 
0046 
0047 
0048 
0049 
0050 
0051 
0052 
0053 
0054 
0055 
'10  56 
A)57 
0058 
0059 


SUBROUT I NE  OUTPUT ( I NPBDF ) 

PROLOGUE : 

MODULE  NAME:  OUTPUT 

AUTHOR:  G.  BROWN  &  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  1974  &  11/83  (FORTRAN  77) 

FUNCTION:  SUBROUTINE  OUTPUT  ALLOWS  OUTPUT  A  HARDCOPY  OF  "SIMAS"  DATA 
INPUTS:  HARD  COPY  SELECTION.  VARIABLES  IN  COMMONS. 

OUTPUTS:  HARDCOPY  OF  SIMAS  DATA. 

MODULES  CALLED:  NONE 
CALLED  BY:  SVPGRF 


INCLUDE  1 DHST . INC 1 

1  ; - DHST - 

1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

1  !  - -  -  -  - 

1  !  SCHNLD  SOUND  CHANNEL  LAYER  DEPTH  REAL *4 

1  ! 

1  REAL* 4  SCHNLD 

1 

1  COMMON  /DHST/  SCHNLD 

1  ! - DHST  END - 

INCLUDE  ’ENVN. INC' 

1  j - ENVN - 

1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

1  ;  -  -  -  - 

1  !  BIO  (2)  BIOLOGICAL  BACK  SCATTERING  REAL *4  -57.  &  -47. 

1  !  DLYR  LAYER  DEPTH  REAL *4 

1  !  MGS  MGS  PROVINCE  INTEGER* 2 

1 

1  REAL *4  BIO, DLYR 

1  INTEGER* 2  MGS 

1  DATA  BIO/-57  .  ,-47./ 

1 

1  COMMON  /ENVN/  BIO ( 2 ), DLYR, MGS 

1 

1  i - END  ENVN - 

INCLUDE  'GRF. INC’ 

1  j - GRF - 

1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

1  t  -  -  -  - 

1  !  DBT  (25)  DEPTH  OF  DEPTH/VEL  PAIR  REAL *4 

1  !  IANS  PREDICTION  TYPE  INTEGER* 2  -2  TO  +2 

1  !  ILYR  INDEX  FOR  LAYER  DEPTH  INTEGER* 2 

1  !  INBT  OPERATOR  ENTERED  #  OF  BT  POINTS  INTEGER* 2 

1  !  ISVP  LATEST  OR  HISTORICAL  BT  FLAG  INTEGER* 2  1  OR  2 

1  !  12000  SVP  INDEX  FOR  2000  FT  DEPTH  INTEGER* 2 

1  !  VBT  (25)  VELOCITY  FOR  DEPTH  PAIR  REAL*4  REAL*4 

1 

1  REAL* 4  DBT, VBT 

1  INTEGER* 2  I ANS , I LYR , INBT , ISVP , I  2 000 

1 

1  COMMON  /GRF/  I ANS , ISVP , I LYR,  1 2000  , INBT , DBT ( 2 5 ), VBT ( 2 5 ) 

1 

]_  i - END  GRF - 

INCLUDE  1 LOC . INC ’ 

1  ! - LOC - 

1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

1  !  -  -  -  - 


c-va.i 


0060 
0061 
J  0  6  2 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 

0081 

0082 

0083 


0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 

0101 

0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 

0111 

0112 

0113 

0114 

\L15 

Al6 

0117 

0118 


1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 


INDX 

LAT  ( 4  ) 

LONG  { 4  ) 

NMAREA  (20) 
NOC 
RCZ 


SSP  INDEX 

LATITUDE 

LONGITUDE 

AREA  OCEAN  NAME 

NUMBER  OF  OCEAN 

RANGE  TO  CONVERG. 


INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
BYTE 

INTEGER *2 
ZONE  REAL *4 


i 


REAL *4  RCZ 

INTEGER*2  INDX, LAT , LONG , NOC 
BYTE  NMAREA (20) 

COMMON  /LOC/  LAT ( 4 ) , LONG ( 4 ) , NOC , I NDX , RCZ , NMAREA 
- END  LOC - 


INCLUDE  'OCEANS. INC' 


1 

1  ! 
1  ! 
1  ! 
1 
1 
1 
1 
1 


OCEANS 


i 


VARBL  SIZE 
I OCEAN  T50T 


PURPOSE 


ARRAY  OF  NAMES  OF  OCEANS 


TYPE 


DATA 


INTEGER* 2  I OCEAN 
DIMENSION  I OCEAN (50) 


0084 

1 

DATA 

I  OCEAN/ ' NO 

, ' RT '  ,  '  H 

’ , 'PA' 

, 'Cl ’ , ' FI 

'  ,  'C 

'  ,  '  OC 

0085 

1 

1 

'NO'  , 

' RT ' ,  '  H  '  , 

AT ' , ' LA ' , 

'  NT  '  ,  ’ 

IC  ,  '  O’  , 

'CE'  , 

'  AN’  , 

0086 

1 

2 

'ME'  , 

'DI ' ,  'TE'  , 

RR ' , 1  AN '  , 

'  EA '  ,  ' 

N  ' , 'SE'  , 

'A  '  , 

»  t 

r 

0087 

1 

3 

’  IN'  , 

' DI ' , 'AN' , 

0','CE', 

'  AN'  ,  ' 

»  1  » 
f  f 

t  I 

r 

i  » 

r 

R088 

1  • 

4 

'NO'  , 

'RW' , 'EG' , 

IA','N  ', 

'SE'  ,  ' 

At  »  » 

^  r  t 

t  i 

t 

’  ’/ 

/089 

1 

0090 

1 

COMMON  /OCEANS/ 

I OCEAN 

' EA '  ,  '  N 


1 

1  ! 

1 
1 
1 
1 
1 
1 
1 
1 
1 
1 
1 
1 
1 
1 
1 
1 
1 
1 
1 
1 
1 
1 
1 
1 
1 


INCLUDE  'S VP. INC' 


END  OCEANS 


-SVP- 


VARBL  SIZE 


PURPOSE 


BDF 

BIOP 

BTDATE 

BTTIME 

C 

cc 

cs 

DEG 

EL 

F 

GRDS 
I  TO 
MGSOP 
N 

NN 

PI 

SNDATE 

SNTIME 

SYDATE 

SYTIME 

TMP 

UMKZ 


(9) 

(8) 

(50) 

(50) 


(9) 

(8) 

(9) 

(8) 


BOTTOM  DEPTH  IN  FATHOMS 
BIOLOGICAL  BACK  SCATTERING  COEF 
DATE  OF  LAST  BT  INPUT 
TIME  OF  LAST  BT  INPUT 
VELOCITY  (PAIRED  WITH  Z  FOR  SVP) 
VELOCITY  (PAIRED  WITH  ZZ  FOR  SVP 
SOUND  VELOCITY  AT  SURFACE 
TEMPERATURE  (DEG) 

LAYER  DEPTH 

FREQUENCY 

GRIDS 

MINIMAL  2-WAY  TRAVEL  TIME 
MGS  PROVINCE  NUMBER 

#  OF  DEPTH/VELOCITY  PAIRS 

#  OF  DEPTH/ VELOCITY  PAIRS 
MATHEMATICAL  CONSTANT  PI 
DATE  SYS  PARMS  LAST  UPDATED 
TIME  SYS  PARMS  LAST  UPDTAED 
CURRENT  DATE  READ  FROM  SYSTEM 
CURRENT  TIME  READ  FROM  SYSTEM 
TEMPERATURE 

BOTTOM  BACK  SCATTERING  COEF. 


TYPE 

REAL *4 
REAL *4 
BYTE 
BYTE 
REAL *4 
)  REAL* 4 
REAL *4 
REAL*4 
DATA 
REAL  *4 
REAL *4 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
REAL *4 
BYTE 
BYTE 
BYTE 
BYTE 
REAL *4 
REAL *4 


RANGE 


57.2957795 

0.0164 

3.1415927 


-28.0 


c-Hl-l 


0119  1 

0120  1 
Jl21  1 
0122  1 
0123  1 

0124  1 

0125  1 

0126  1 
0127  1 

0128  1 
0129  1 

0130  1 

0131  1 

0132  1 

0133  1 

0134  1 

0135 
0136  1 

0137  1 

0138  1 

0139  1 

0140  1 

0141  1 

0142  1 

0143  1 

0144  1 

0145  1 

0146  1 

^147  1 

7148  1 

0149  1 

0150  1 

0151  1 

0152 
0153 
0154 
0155 
0156 
0157 
0158 
0159 
0160 
0161 
0162 
0163 
0164 
0165 
0166 
0167 
0168 
0169 
0170 
0171 
0172 
0173 

\L74 

717  5 
0176 
0177 


WS 

WIND 

SPEED 

REAL *4 

Z 

(50) 

DEPTH 

OF 

POINT 

OF 

SOUND 

SPEED 

REAL *4 

ZZ 

(50) 

DEPTH 

OF 

POINT 

OF 

SOUND 

SPEED 

REAL *4 

INTEGER*2  I TO , MGSOP , N , NN 

REAL *4  BDF , BIOP , C ( 50 ) ,CC(5Q) , CS , DEG , EL , F , GRDS 

REAL *4  P I , TMP , UMKZ , WS , Z( 50 ) ,ZZ(50) 

BYTE  SYDATE ( 9 ) ,SYTIME(8) , BTDATE ( 9 ) , BTTIME ( 8 ) 

BYTE  SNDATE ( 9 ) , SNT I ME ( 8 ) 

DATA  PI , DEG, GRDS/3. 1415927, 57. 2957795, 0.0164/ 

DATA  UMKZ/- 2 8./ 


COMMON  /SVP/  F, N, Z,C, EL, MGSOP, BDF, WS , CS , TMP, BIOP, 

1  UMKZ, PI, DEG, GRDS, ITO, ZZ , CC , NN , 

2  SYDATE , S YT IME , BTDATE , BTT I ME , SNDATE , SNT I ME 

- SVP-END - 

INCLUDE  ' SVP1 . INC ' 

- SVPl - 

VARBL  SIZE  PURPOSE  TYPE  RANGE 


BUFFER  (224) 

DS  (30) 

J20 

NS 

NSN 

SLNTY 

VS  (30) 


HISTORICAL  DATA  FILE  BUFFER 
HISTORICAL  DEPTH 
#  OF  DEEP  OCEAN  DEPTH/VEL  PAIRS 
TOTAL  #  OF  PAIRS  IN  HISTORICAL 
MONTH  NUMBER  ( 1 = J AN . , ETC ) 
SALINITY 

HISTORICAL  VELOCITY 


REAL *4 
REAL *4 
INTEGER* 2 
INTEGER* 2 

INTEGER* 2  1  TO  12 

REAL *4 
REAL *4 


REAL* 4  BUFFER, DS, SLNTY, VS 

INTEGER*2  J20,NSN,NS 

COMMON  /SVPl/  J20,BUFFER(224) , NSN, SLNTY, DS(30) ,VS(30) , NS 
- end  SVPl - 


VARBL  SIZE  PURPOSE 


TYPE  RANGE 


I 

IBDF 
I  BEG 
I  END 
INPBDF 
IOF 
I  OS 
IWS 

JSPDAT  (15) 

LAYR 

M 

RMONTH  (12) 
SCHMXD 


COUNTER 

ROUNDED  BOTTOM  DEPTH 

ARRAY  JSPDAT  START  POINTER 

ARRAY  JSPDAT  START  POINTER 

INPUTTED  BOTTOM  DEPTH  IN  FATHOMS 

ARRAY  I OCEAN  STOP  POINTER 

ARRAY  I OCEAN  START  POINTER 

ROUNDED  WIND  SPEED 

'HISTORICAL  LATEST  XBT  KEYPUNCHED' 

ROUNDED  LAYER  DEPTH 

COUNTER 

ARRAY  OF  NAMES  OF  MONTHS 
SOUND  CHANNEL  MAX  DEPTH 


INTEGER* 2 
INTEGER*2 
INTEGER* 2 
INTEGER*2 
INTEGER* 2 
INTEGER* 2 
INTEGER*2 
INTEGER* 2 
LABELS  DATA 

INTEGER*2 
INTEGER* 2 
DATA 
REAL *4 


***  VARIABLES  NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMON  *** 


INTEGER* 2  I , IBDF, IBEG, IEND , INPBDF , IOF , IOS , IWS , JSPDAT , LAYR, M 
REAL *4  SCHMXD 

DIMENSION  JSPDAT ( 15 ) 

DIMENSION  RMONTH (12) 

DATA  RMONTH/ ' JAN  ' , ' FEB  f , ’ MAR  ' , ' APR  ’ , 

1  ' MAY  ' , ' JUN  ' , ' JUL  ’ , ' AUG  ' , 


C-H2.3 


0178 

0179 

)180 

0181 

0182 

! - 

0183 

0184 

0185 

0186 

0187 

0188 

1 - 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 

0201 

0202 

0203 

0204 

! - 

0205 

Q206 

7207 

0208 

0209 

0210 

0211 

0212 

0213 

0214 

0215 

0216 

0217 

0218 

0219 

0220 

0221 

0222 

0223 

0224 

i - 

0225 

11 

0226 

22 

0227 

3005 

0228 

0229 

3008 

0230 

3135 

0231 

3150 

0232 

3160 

^233 

3162 

/234 

3163 

0235 

3165 

0236 

3170 

2  ' SEP  ' , ' OCT  ' , ' NOV  ' , ' DEC  ' / 

DATA  JSPDAT/'HI ' , 'ST' , 'OR' , ' IC , 'AL' , 'LA' , 'TE' , 'ST' , '  X','BT', 
1  'KE' , 'YP' , 'UN' , 'CH' , 'ED'/ 


SCHMXD  =  1000. 
IWS=WS+0 . 5 
LAYR=DLYR+0 . 5 
IBDF=BDF+0 . 5 


PRELIMINARIES - 

!  SOUND  CHANNEL  MAX  DEPTH 
!  ROUND  WIND  SPEED 
!  ROUND  CHANNEL  LAYER  DEPTH 
!  ROUND  BOTTOM  DEPTH 


IF( IANS . NE . 2 )  THEN 
WRITE( 6,11) BTDATE ( 1 ) , BTDATE ( 2 ) , 

1  BTTIME ( 1 ) , BTTIME ( 2 ) , BTTIME ( 4 ) 

2  BTDATE (  5 )  , BTDATE ( 6 ) , BTDATE ( 8 ) 
ELSE 

WRITE (6,22)  RMONTH(NSN) 

END  IF 

IOS=(NOC-l) *10+1 
IOF= IOS+9 

IF( ISVP.EQ. 5)  THEN 

WRITE( 6 , 3008 )  NMAREA , LAT , LONG 
ELSE 

WRITE( 6 , 3005 )  ( I OCEAN ( I ) , I = I OS 
END  IF 


-WRITE  TITLES - 

!  OPERATIONAL  PREDICTION 
!  WRITE  UPDATE  DATE  &  TIME 
BTTIME ( 5 ) , BTDATE ( 4 ) , 

BTDATE ( 9 ) 

!  FORECAST  PREDICTION  TYPE 
!  WRITE  FOR  MONTH 
!  END  IF  BLOCK 
!  SET  I OCEAN  START  POINTER 
!  SET  I OCEAN  STOP  POINTER 
!  IF (KEYPUNCHED) 

!  WRITE  OCEAN  AREA  INFO 
!  NOT  KEYPUNCHED 
I OF ), LAT, LONG!  WRITE  OCEAN  INFO 
!  END  IF  BLOCK 


IBEG= ( ISVP-1 ) *5+1 
IF( ISVP.EQ. 5)  IBEG=11 
IEND= IBEG+4 

WRITE (6,3135) ( JSPDAT ( I ) ,I=IBEG 
WRITE ( 6 , 3150 ) 

WRITE ( 6,3160)  ( I , Z( I ) ,C( I ) , 1=1 
WRITE (6,3175)  SLNTY 
WRITE (6, 3180)  MGS 
I F ( ISVP.EQ. 5)  THEN 
WRITE( 6 , 3162 )  INPBDF 
ELSE 

WRITE( 6,3200)  INDX 
WRITE(6 , 3163)  INPBDF 
WRITE( 6,3165)  I BDF 
END  IF 

WRITE (6, 3 170)  IWS , LAYR , RCZ 
IF (SCHNLD.GT. SCHMXD)  WRITE (6, 3 
IF (SCHNLD.LE. SCHMXD)  WRITE (6, 3 


- WRITE  DATA  FOR  OCEAN  AREA-- 

!  SET  JSPDAT  START  POINTER 
!  IF (KEYPUNCHED) 

!  SET  JSPDAT  STOP  POINTER 
I END) !  WRITE  DATA  SOURCE 

!  WRITE  #,  DEPTH,  VELOCITY 
N)  !  WRITE  #,  DEPTH,  VELOCITY 
!  SALINITY 
!  MGS  AREA 
!  KEYPUNCHED 
!  INPUTTED  BOTTOM  DEPTH 
!  NOT  KEYPUNCHED 
!  SSP  INDEX 

!  INPUTTED  BOTTOM  DEPTH 
!  CORRECTED  BOTTOM  DEPTH 
!  END  IF  BLOCK 
!  WIND  SPEED, LAYER, RANGE  CZ 
71)!  SOUND  CHANNEL  INVALID 
.72)  SCHNLD  !  SOUND  CHANNEL 


FORMAT  STATEMENTS - 

FORMAT ( / '  BT  DATE  AND  TIME  ',6A1,'Z  ' , 3A1 , '  ',2Al) 

FORMAT (1H1,T2 2, 'DATA  TO  BE  USED  FOR  FORCASTING : ' , 1A4 ) 

FORMAT (2X, 10 A2 , 3X, ' LAT: ' , 3( 12, IX) , 

1  A2 , '  LONG: ' ,313, IX, A2) 

FORMAT (2X, 2 0A1,3X, 'LAT: ' , 3 ( 12 , IX) , A2 , '  LONG: ' ,3I3,1X,A2) 

FORM AT (/T 15, 'SOUND  VELOCITY  PROFILE  DATA’ /24X, 5A2 ) 

FORMAT (/T15, ’NO. ' ,T25, 'DEPTH' ,T33, 'VELOCITY' ) 

FORMAT (T1 5 , I  2 , IX , 2F10 . 1 ) 

FORMAT (T1 5, ' INPUT  BOTTOM  DEPTH  IS  ’,15,'  FATHOMS') 

FORMAT (T15 , 'CHART  OR  FATHOMETER  BOTTOM  DEPTH  IS  ',15,'  FATHOMS') 
FORMAT (T1 5, 'CORRECTED  BOTTOM  DEPTH  IS  ',15,'  FATHOMS') 

FORMAT (T1 5, 'TRUE  WIND  SPEED  IS  ',12,'  KNOTS' 


c-va.w 


0237 

0238 

4239 

1  /T15, '*** CANDIDATE  ACOUSTIC  PATHS****' 

2  /T25, 'LAYER  DEPTH  IS  ',16,'  FEET* 

3  /T2 5, 'CONVERGENCE  ZONE  RANGE  IS  ',F5.1,' 

KYDS '  ) 

0240 

3171 

FORMAT (T2 5, 'SOUND  CHANNEL  NOT  USABLE') 

0241 

3172 

FORMAT (T2 5, 'SOUND  CHANNEL  AXIS  DEPTH  IS  ',F7.1, 

'  FEET '  ) 

0242 

3175 

FORMAT (//T15, 'SALINITY  IS  ' ,F6.2) 

0243 

3180 

FORMAT (T1 5, 'MGS  AREA  IS  ’ll) 

0244 

3200 

FORMAT (T15, 'SSP  AREA  IS  ’,12) 

0245 

0246 

0247 

RETURN 

END 

COMMAND  QUALIFIERS 

FORTRAN  /CHECK55  ALL/LI  ST/SHOW55  (INCLUDE,  NOMAP)  OUTPUT. F77 

/CHECK55 ( BOUNDS , OVERFLOW , UNDERFLOW ) 

/DEBUG55  ( NOSYMBOLS ,  TRACEBACK ) 

/STANDARD3 ( NOSYNTAX , NOSOURCE_FORM ) 

/SHOW3 ( NOPREPROCESSOR , INCLUDE , NOMAP ) 

/F77  /NOG  FLOATING  /I4  /OPTIMIZE  /WARNINGS  /NOD  LINES  /NOCROSS  REFERENCE 


COMPILATION  STATISTICS 


Run  Time: 
Elapsed  Time: 
Page  Faults: 
Dynamic  Memory: 


3.49  seconds 
12.77  seconds 
494 

145  pages 


✓ 


c-va.  s' 


0001 

^002 

>4003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 

0011 

0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 

0021 

0022 

0023 

0024 

0025 

0026 

0027 

0028 

V)29 

J030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 


1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 


INTEGER*2  FUNCTION  PDIST(NDX) 

PROLOGUE : 

MODULE  NAME:  PD I ST 

AUTHOR:  E.  PETR IDES  &  P.  FRAGEORGIA  OF  SYSCON,  INC 

RECODED:  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  1982  &  6/84  (FORTRAN  77) 

FUNCTION:  THIS  SUBROUTINE  IS  DESIGNED  TO  ROTATIONAL  ANALYSIS  UPON  A 
SERIES  OF  SEGMENTS  OF  POINTS,  RETURNING  THE  DISTANCE  TO 
THE  NEAREST  POINT  TO  THE  SHIP. 

INPUTS:  VARIABLES  NEEDED  FOR  ROTATION  ANALYSIS 
OUTPUTS:  DISTANCE  TO  NEAREST  POINT  TO  THE  SHIP 
MODULES  CALLED:  END1 ,  END 2 
CALLED  BY:  CRUNCH 


ASSUMPTIONS  MADE  BY  THIS  ALGORITHM: 

1)  LEGIT  SEGS:  1-6  VERT  BORDER,  7-12  HORZ  BORDER,  >12  DIGITIZED 

2)  SEGMENTS  MUST  BE  LISTED  IN  CONNECTED  CLOCKWISE  ORDER 

3)  NEGATIVE  SEGS  INDICATE  REVERSE  ORDER  OF  POINTS 

4)  ONLY  SEGS  LISTED  ARE  THOSE  ON  OUTER  PERIMETER 


INCLUDE  'MAP. PAR' 

PARAMETER  STOLEN=3800 
PARAMETER  SEGLEN=60 ,  POLLEN=40 
PARAMETER  WRKLEN=1000,  NDXLEN=300 
PARAMETER  MAXDTY=3 
PARAMETER  TOL=3 
PARAMETER  DEG=57 . 2957795 
PARAMETER  RAD= . 017453293 
PARAMETER  PI  =  3 . 14159265 
PARAMETER  ERAD=3440.3 
PARAMETER  S25 1=63001 
PARAMETER  TW015=32768 

INTEGER* 2  MAXDTY , NDXLEN , POLLEN , SEGLEN , STOLEN , TOL , WRKLEN 
INTEGER* 4  S251,TW015 
REAL *4  DEG , ERAD , P I , RAD 

INCLUDE  ' CBC2 . INC’ 

- CBC2 . INC - 

SIZE  PURPOSE  TYPE  RANGE 


VARBL 


BCOORD  (25,2) 

INTEGER *2  BCOORD (2 5, 2) 


COMMON  /CBC/ 


INCLUDE  ' CLOC . INC ' 


BCOORD 

- END  CBC2 . INC- 


-CLOC. INC- 


0053 

1 

i 

• 

VARBL  SIZE 

PURPOSE 

TYPE 

0054 

1 

i 

• 

— 

0055 

1 

i 

• 

BLAT 

BASE  LATITUDE 

REAL *4 

056 

1 

i 

BLNG 

BASE  LONGITUDE 

REAL *4 

<✓057 

1 

t 

• 

LAT 

LATITUDE  OF  SHIP'S  LOCATION 

REAL *4 

0058 

1 

i 

* 

LNG 

LONGITUDE  OF  SHIP'S  LOCATION 

REAL *4 

0059 

1 

i 

NMLT50 

#  OF  NAUTICAL  MILES  PER  50TH  DEGREE 

REAL *4 

C-V?.| 


0060  1  !  OF  LATITUDE 

0061  1  !  NMLG50  #  OF  NAUTICAL  MILES  PER  50TH  DEGREE  REAL* 4 

BO 62  1  !  OF  LONGITUDE 

0063  1  ! 

0064  1  REAL*4  LAT , LNG , BLAT , BLNG , NMLT50 , NMLG50 

0065  1 

0066  1  COMMON  /CLOC/  LAT , LNG , BLAT , BLNG, NMLT50 , NMLG50 

0067  1  ! - END  CLOC.  INC - 

0068  INCLUDE  'CS.INC' 

0069  1  !  - CS - 

0070  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0071  1  ! -  -  -  - 

0072  1  !  S  -1,3800  POLYGON  AND  SEGMENT  STORAGE  ARRAY  REAL  *  4 

0073  1  !  STOLEN  STORAGE  ARRAY  LENGTH  (FOR  SEGS  &  POLYS)  PARM 

0074  1  ! 

0075  1  REAL *4  S(-l:STOLEN) 

0076  ■  1 

0077  1  COMMON  /CS/  S 

0078  1  ! - CS-END - 

0079  1 

0080  ! 

0081  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0082  ! -  -  - 

0083  !  D  MAX  DISTANCE  BETWEEN  2  POINTS  ON  EARTH  REAL *4 

0084  !  I  LOOP  COUNTER  INTEGER* 2 

0085  !  J  SEGMENT  INTEGER* 2 

0086  !  N  NUMBER  OF  SEGMENTS  IN  A  POLYGON  REAL *4 

0087  !  NDX  POINTER  TO  THE  #  OF  SEGMENTS  USED  INTEGER* 2 

0088  !  Q  FACTOR  REAL *4 

/089  !  R  ROTATIONAL  ANGLE  REAL *4 

0090  !  T  FACTOR  REAL *4 

0091  !  TEMP  FACTOR  REAL *4 

0092  !  XI  STARTING  X  COORDINATE  REAL *4 

0093  ' !  X2  ENDING  X  COORDINATE  REAL *4 

0094  !  X3  DISTANCE  BETWEEN  X  COORDINATES  REAL *4 

0095  !  Y1  STARTING  Y  COORDINATE  REAL  *  4 

0096  !  Y2  ENDING  Y  COORDINATE  REAL *4 

0097  !  Y3  DISTANCE  BETWEEN  Y  COORDINATES  REAL *4 

0098  ! 

0099  !  ***  VARIABLES  NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMONS  *** 

0100 

0101  INTEGER* 2  I , J , END1 , END2 , NDX 

0102  REAL *4  D , N , Q , R, T , TEMP , XI , Y1 , X2 , Y2 , X3 , Y3 

0103 

0104  ! - PRELIMINARIES - 

0105  N=10  . **5  !  #  OF  SEGMENTS  IN  A  POLYGON 

0106  R=0 .  I  RESET  ROTATION  (DEGREES) 

0107  D=(ERAD*PI )**2  .  !  MAX  DIST  OF  2  PTS  ON  EARTH 

0108  DO  4  1=1, IIFIX(S(NDX+1) )  !  DO  FOR  ALL  SEGMENTS  IN  POLYGON 

0109  J=IIFIX(S(NDX+I+2) )  !  SEGMENT 

0110 

0111  ! - VERTICAL  BORDER  SEGMENTS - 

0112  IF  (ABS(J) .LE.6)  THEN  !  VERTICAL  BORDER 

0113  Yl=FLOATI (END1(NDX, I ) )  !  STARTING  Y  COORDINATE 

0114  Y2=FLOATI (END2 (NDX, I ) )  !  END I NG  Y  COORD I NATE 

0115  XI = FLOAT I ( BCOORD( J+13 ,  2 )  )  !  STARTING  X  COORDINATE 

/II 6  X2=Xl  !  ENDING  X  COORDINATE 

0117  END  IF  !  END  IF  BLOCK 

0118 


C-MS.  2- 


0119 

0120 

)121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

JQ.48 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 

0161 


- HORIZONTAL  BORDER  SEGMENTS - 

IF  ( ABS ( J ) . GT . 6 . AND . ABS ( J ) . LE . 12 )  THEN  !  HORIZONTAL  BORDER 


Xl=FLOATI (END1(NDX, I) ) 
X2=FLOATI ( END2 (NDX , I ) ) 
Yl=FLOATI ( BCOORD ( J+13 , 1 ) ) 
Y2=Y1 
END  IF 


!  STARTING  X  COORDINATE 
!  ENDING  X  COORDINATE 
!  STARTING  Y  COORDINATE 
!  ENDING  Y  COORDINATE 
!  END  IF  BLOCK 


- • - DIGITIZED  SEGMENTS - 

IF  (ABS(J) .GT. 12)  THEN  !  DIGITIZED  SEGMENT 

D=AMIN1 ( D , S ( ABS ( J ) +2 ) )  !  DIST  TO  NEAREST  PT  IN  POLYGO 

IF  (D.LT..25)  GOTO  6  !  GO  SET  DISTANCE  TO  ZERO 

R=R+FLOATI ( IS IGN ( 1 , J ) ) *S (  I IABS ( J ) +1 )  !  ROTAT I ONAL  ANGLE 
GOTO  4  !  GO  SET  DISTANCE 

END  IF  !  END  IF  BLOCK 


4 


6 

999 


ROTATIONAL 
STARTING 
STARTING 
ENDING  X 
ENDING  Y 
DISTANCE 
DISTANCE 


ANALYSIS - - - 

X  COORDINATE 
Y  COORDINATE 
COORDINATE 
COORDINATE 

BETWEEN  X  COORDINATES 
BETWEEN  Y  COORDINATES 
DISTANCE 


X1=(X1-LNG) *NMLG50 
Yl= ( Yl-LAT) *NMLT50 
X2  = ( X2 - LNG ) *  NMLG5 0 
Y2=(Y2-LAT)*NMLT50 
X3=X2-X1 
Y3=Y2-Y1 

IF  (X3.EQ.0.  .AND.  Y3.EQ.0.)  GOTO  4  !  ZERO 
Q=-(X1*X3+Y1*Y3)/(X3**2+Y3**2)  1  FACTOR 
IF  (Q.LE.0.)  T=Xl**2+Yl**2  !  FACTOR 

IF  (Q.GT.0.  .AND.  Q.LT.l.)  T= ( Xl+Q*X3 ) **2+ ( Y1+Q*Y3 ) **2  !  FACT 
IF  (Q.GE.l.)  T=X2**2+Y2**2  !  FACTOR 

D=AMIN1(D,T)  !  DISTANCE  TO  NEAREST  PT  IN  PO 

T=SQRT( (X1**2+Y1**2)*(X2**2+Y2**2) )  !  FACTOR 
IF  ( AINT (T*N) /N. EQ. 0 . )  GOTO  6  !  ZERO  DISTANCE 
TEMP=DEG*ACOS(AINT( { (X1*X2+Y1*Y2)/T)*N)/N)  !  FACTOR 
IF  (X2*Y1.NE.Y2*X1)  R=R+SIGN(TEMP , (X2*Y1-Y2*X1 ) )  !  SUM  SEGMEN 


CONTINUE 

IF  (ABS(R) .LT.355. )  THEN 
PD I ST= I N I NT ( SQRT ( D ) ) 
ELSE 

PDIST=-ININT(SQRT(D) ) 
END  IF 
GO  TO  999 
PDIST=0 
RETURN 
END 


END  DO  LOOP 

SEGMENTS  DO  NOT  ENCIRCLE  SHIP 
DISTANCE  TO  THE  NEAREST  POINT 
SEGEMNTS  DO  FULLY  ENCIRCLE  SHI 
SIGNAL  COMPLETE  POLYGON 
END  IF  BLOCK 

RETURN  TO  CALLING  ROUTINE 
SIGNAL  TO  CLOSE  TO  CALL 
RETURN  TO  CALLING  ROUTINE 
END  SUBROUTINE 


c-y 3 .3 


0001 
0002 
p  0  0  3 
0004 
0005 
0006 
0007 
0008 
0009 
0010 
0011 
0012 
0013 
0014 
0015 
0016 
0017 
0018 
0019 
0020 
0021 
0022 
0023 
0024 
0025 
0026 
0027 
0028 
0029 
>030 
1)031 
0032 
0033 
0034 
0035 
0036 
0037 
0038 
0039 
0040 
0041 
0042 
0043 
0044 
0045 
0046 
0047 
0048 
0049 
0050 
0051 
0052 
0053 
0054 
0055 
0056 
)057 
0058 
0059 


SUBROUTINE  SETOAC 
PROLOGUE: 

MODULE  NAME:  SETOAC 

AUTHOR:  E.  PETRI DES  &  P.  FRAGEORGIA  OF  SYSCON,  INC 
RECODED:  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  1982  &  6/84  (FORTRAN  77) 

FUNCTION:  THIS  SUBROUTINE  IS  DESIGNED  TO  DETERMINE  WHICH  DATA 
BASE  FILE  THE  PROGRAM  IS  TO  USE  ACCORDING  TO  ITS 
OCEAN  AREA  CODE. 

INPUTS:  OPERATOR  ENTERS  DESIRED  OCEAN  NAME 
OUTPUTS:  DATA  BASE  FILE  TO  BE  USED 
MODULES  CALLED:  NONE 
CALLED  BY:  MAP 


1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1  ! 

1  ! 

1  ! 

1  !  - 

1  !  VARBL 

1  ! - 

1  !  FNAME 
1  !  OPEN 
1  ! 

1 

1 

1 

1 

1  ! - 

1 


VARBL 


OAC 

ONAME 

DNAME 


INCLUDE  'MAP. PAR' 

PARAMETER  STOLEN=3800 
PARAMETER  SEGLEN=60 ,  POLLEN=40 
PARAMETER  WRKLEN=1000,  NDXLEN=300 
PARAMETER  MAXDTY=3 
PARAMETER  TOL=3 
PARAMETER  DEG=57 . 2957795 
PARAMETER  RAD= . 017453293 
PARAMETER  PI=3 . 14159265 
PARAMETER  ERAD=3440.3 
PARAMETER  S251=63001 
PARAMETER  TW015=32768 

I NTEGER*  2  MAXDTY , NDXLEN , POLLEN , SEGLEN , STOLEN , TOL , WRKLEN 
INTEGER*4  S251,TW015 
REAL *4  DEG , ERAD , P I , RAD 

INCLUDE  ' CFILE . INC ' 

- CFILE. INC - 

SIZE  PURPOSE  TYPE  RANGE 


(21)  MAP  FILE  NAME  CHAR 

OPEN  FLAG  LOG I CAL *1  .FALSE. 

LOG I CAL *1  OPEN 

CHARACTER* 1  FNAME (21) 

COMMON  /CFILE/  OPEN, FNAME 

- END  CFILE. INC - 

INCLUDE  ' CNAME . INC ' 

- CNAME. INC - 

SIZE  PURPOSE  TYPE  RANGE 


(25)  OCEAN  NAME 

()  'MGS',  'SSP',  OR  'BDEPTH'  TEXT  STRINGS 

I NTEGER* 4  ONAME ( 2 5 ) , DNAME ( 2 *MAXDTY ) 

I NTEGER* 2  OAC 

COMMON  /CNAME/  ONAME , DNAME , OAC 
- END  CNAME. INC - 

INCLUDE  ' CTSK . INC ' 


0060 
0061 
A  062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 

0081 

0082 

0083 

0084 

0085 

0086 

0087 

^088 

J089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 

0101 

0102 

0103 

0104 

0105 

0106 

0107 


1  j  - CTSK.INC - 

1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

1  !  TBDPTH 
1  !  TFLG 
1  !  TLAT  (3) 

1  !  TLNG  (3) 

1  !  TMGS 
1  !  TOAC 
1  !  TSSP 
1  ! 

1  REAL* 4  TMGS, TSSP, TBDPTH 

1  INTEGER* 2  TFLG , TOAC , TLAT ( 3 ) , TLNG ( 3 ) 

1 

1  COMMON  /CTSK/  TFLG, TOAC , TLAT, TLNG, TMGS , TSSP , TBDPTH 

1  ! - END  CTSK.INC - 

1 


VARBL  SIZE  PURPOSE 


TYPE  RANGE 


I 

II 
12 
J 


LOOP  COUNTER 
ONAME  POINTER  END 
ONAME  POINTER  END 
COUNTER 


INTEGER* 2 

INTEGER* 2  1,6,11,16,21 
INTEGER* 2  5,10,15,20,25 
INTEGER* 2 


***  VARIABLES  NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMONS  *** 


INTEGER* 2  I ,11, 12, J 

TYPE  * , ' ! WOR  0 ' 

1  WRITE( 5,2) 

DO  4  1-1,5 
11=5*1-4 
12=5*1 

WRITE( 5 , 3 )  I , ( ONAME { J ) , J  = 1 1 , 
4  CONTINUE 

WRITE (5,5) 

READ ( 5 , * )  OAC 

IF  (OAC.LT.l  .OR.  OAC.GT.5) 
TOAC =0 AC 

FNAME ( 4 ) =CHAR ( OAC  +  48) 

RETURN 


!  4025/27  ERASE  COMMAND 
!  VALID  OCEAN  AREAS  TITLE 
!  DO  FOR  5  OCEANS 
!  POINTER  START  1,6,11,16,21 
!  POINTER  END  5,10,15,20,25 
2)  !  VALID  OCEAN  AREA  MENU 

!  END  LOOP 
!  OCEAN  AREA  PROMPT 
!  OCEAN  AREA  RESPONSE 
GOTO  4  !  INVALID  RESPONSE 

!  SET  PARAM  TO  BE  PASSED 
!  CHANGE  TO  ASCII 
!  RETURN  TO  CALLING  ROUTINE 


! - FORMAT  STATEMENT - 

2  FORMAT(4{/) ,T30, 'VALID  OCEAN  AREAS  ARE:') 

3  FORMAT ( T4  2 , 1 1 , ' )  ' ,5A4) 

5  FORMAT ( /X, ' ENTER  THE  CODE  OF  THE  OCEAN  AREA  DESIRED  ' ,$) 

END 


c-HH.  2- 


0001 
0002 
5003 
0004 
0005 
0006 
0007 
0008 
0009 
0010 
0011 
0012 
0013 
0014 
0015 
0016 
0017 
0018 
0019 
0020 
0021 
0022 
0023 
0024 
0025 
0026 
0027 
0028 
<3029 
J  0  3  0 
0031 
0032 
0033 
0034 
0035 
0036 
0037 
0038 
0039 
0040 
0041 
0042 
0043 
0044 
0045 
0046 
0047 
0048 
0049 
0050 
0051 
0052 
0053 
0054 
0055 
“\056 
J057 
0058 
0059 


PROGRAM  SIMAS 
PROLOGUE : 

MODULE  NAME:  SIMAS 

AUTHOR:  G. BROWN,  S.  LEFLEUR,  W.  WACHTER , CODE  3333,  NUSC/NLL 
DATE:  1974,  7/83,  &  10/83  (FORTRAN  77) 

FUNCTION:  EXECUTIVE  PROGRAM  FOR  SONAR  IN-SITU  MODE  ASSESSMENT 
SYSTEM  (SIMAS). 

PROMPTS  FOR  PREDICTION  TYPE  AND  MENU  SELECTION. 
CONTROLS  AND  EXECUTES  SUBROUTINES  NEEDED  FOR  OPTIONS 
SELECTED  BY  OPERATOR. 

INPUTS:  OPERATOR  SELECTION  FOR  PREDICTION  TYPE  AND  MENU  CHOICE. 

OUTPUTS:  NONE 

MODULES  CALLED:  ACTVLP,  ACTV26,  ENVIRN,  ERRSET,  FORCST,  ICLR, 

OTHERS,  PBB ,  PSSV,  RAXIN,  SVPTRC,  VDS 

INCLUDE  ' ENVN. INC ' 


1  j - ENVN - 

1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

1  , -  -  -  - 

1  !  BIO  _  (2)  BIOLOGICAL  BACK  SCATTERING  REAL *4  -57.  &  -47. 

1  !  DLYR  LAYER  DEPTH  REAL *4 

1  !  MGS  MGS  PROVINCE  INTEGER* 2 

1 

1  REAL *4  BIO, DLYR 

1  INTEGER* 2  MGS 

1  DATA  BIO/-57. ,-47./ 

1 

1  COMMON  /ENVN/  B I O ( 2 ) , DLYR , MGS 

1 

1  ! - END  ENVN - 

INCLUDE  ' GRF . INC ' 

1  ! - GRF - 

1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

1  , -  -  -  - 

1  !  DBT  (25)  DEPTH  OF  DEPTH/VEL  PAIR  REAL* 4 

1  !  IANS  PREDICTION  TYPE  INTEGER* 2  -2  TO  +2 

1  !  ILYR  INDEX  FOR  LAYER  DEPTH  INTEGER* 2 

1  !  INBT  OPERATOR  ENTERED  #  OF  BT  POINTS  INTEGER* 2 

1  !  ISVP  LATEST  OR  HISTORICAL  BT  FLAG  INTEGER* 2  1  OR  2 

1  !  12000  SVP  INDEX  FOR  2000  FT  DEPTH  INTEGER* 2 

1  !  VBT  (25)  VELOCITY  FOR  DEPTH  PAIR  REAL*4  REAL *4 

1 

1  REAL *4  DBT, VBT 

1  INTEGER* 2  I ANS , I LYR , INBT , ISVP ,  1 2000 

1 

1  COMMON  /GRF/  IANS , ISVP , I LYR,  1 2000 , INBT , DBT ( 2 5 ) , VBT( 2 5 ) 

1 

1  j - END  GRF - 

INCLUDE  ' LOC . INC ' 

1  ! - LOC - 

1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

1  ! -  -  -  - 

1  !  INDX  SSP  INDEX  INTEGER* 2 

1  !  LAT  (4)  LATITUDE  INTEGER* 2 

1  !  LONG  (4)  LONGITUDE  INTEGER *2 

1  !  NMAREA  (20)  AREA  OCEAN  NAME  BYTE 

1  !  NOC  NUMBER  OF  OCEAN  INTEGER* 2 

1  <  RCZ  RANGE  TO  CONVERG.  ZONE  REAL *4 


C-HT.I 


0060  1 

0061  1  REAL *4  RCZ 

1)062  1  INTEGER*2  I NDX , LAT , LONG , NOC 

0063  1  BYTE  NMARE A (20) 

0064  1 

0065  1  COMMON  /LOC/  LAT ( 4 ) , LONG ( 4 ) , NOC, INDX, RCZ , NMAREA 

0066  1 

0067  1  ! - END  LOC - 

0068  INCLUDE  'RXIO.INC' 

0069  1  !  - RXIO - 

0070  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0071  1  ! -  -  -  - 

0072  1  !  DELTAR  RANGE  INCREMENT  REAL *4 

0073  1  !  DEMU  DEPRESSION  ANGLE  ( RECIEVER)  REAL* 4 

0074  1  !  DENU  DEPRESSION  ANGLE  (SONAR)  REAL* 4 

0075  1  !  IDL  '  BEAM  DEVIATION  LOSS  FLAG  INTEGER* 2 

0076  1  !  JDL  BEAM  DEVIATION  LOSS  FLAG  INTEGER* 2 

0077  1  !  LAMDA  CYCLE  RANGE  INDEX  INTEGER* 2 

0078  1  !  LAMDAB  CYCLE  RANGE  INDEX  -  FAST  BB  INTEGER*2 

0079  1  !  LAMDAC  NUMBER  OF  FULL  CYCLES  INTEGER* 2 

0080  1  !  MU  SOUND  SPEED  AT  TARGET  DEPTH  INTEGER* 2 

0081  1  !  NPRNT  PLOT  MODE  FLAG  INTEGER* 2 

0082  1  !  NR  #  OF  RANGES  IN  PROP  LOSS  TABLE  INTEGER*2 

0083  1  !  NU  SOUND  SPEED  AT  SONAR  DEPTH  INTEGER*2 

0084  1  !  PLRMS  (200)  PROP  LOSSES  FOR  RANGE  POINTS  REAL *4 

0085  1  !  R  RANGE  TO  START  PROP  LOSS  REAL *4 

0086  1  !  RANGE  (200)  RANGE  POINTS  REAL *4 

0087  1  !  RMAX  RANGE  TO  STOP  PROP  LOSS  REAL *4 

0088  1  !  VBMU  VERTICAL  BEAMWIDTH  (RECEIVER)  REAL *4 

)089  11  VBNU  VERTICAL  BEAMWIDTH  (SONAR)  REAL *4 

0090  1 

0091  1  INTEGER* 2  IDL , JDL , LAMDA, LAMDAB, LAMDAC , MU , NPRNT , NR, NU 

0092  1  REAL  *  4  DELTAR , DEMU , DENU, PLRMS , R, RANGE , RMAX, VBMU , VBNU 

0093  1 

0094  1  DIMENSION  PLRMS (200) ,RANGE( 200) 

0095  1 

0096  1  COMMON  /RXIO/  NU , MU, LAMDA, LAMDAC , LAMDAB , NPRNT , R, RMAX, DELTAR , 

0097  1  1  IDL, DENU, VBNU, JDL, DEMU, VBMU, NR, RANGE, PLRMS 

0098  1 

0099  1  ! - RXIO- END - 

0100  1 

0101  INCLUDE  ' SVP . INC 1 

0102  1  ! - SVP - 

0103  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0104  1  1 - -  -  -  - 

0105  1  1  BDF  BOTTOM  DEPTH  IN  FATHOMS  REAL *4 

0106  1  !  BIOP  BIOLOGICAL  BACK  SCATTERING  COEF  REAL*4 

0107  1  !  BTDATE  (9)  DATE  OF  LAST  BT  INPUT  BYTE 

0108  1  1  BTTIME  (8)  TIME  OF  LAST  BT  INPUT  3YTE 

0109  1!C  (50)  VELOCITY  (PAIRED  WITH  Z  FOR  SVP)  REAL *4 

0110  1  !  CC  (50)  VELOCITY  (PAIRED  WITH  ZZ  FOR  SVP)REAL*4 

0111  1  1  CS  SOUND  VELOCITY  AT  SURFACE  REAL*4 

0112  1  !  DEG  TEMPERATURE  (DEG)  REAL*4  57.2957795 

0113  1  !  EL  LAYER  DEPTH  DATA 

0114  1  1  F  FREQUENCY  REAL* 4 

0115  1  !  GRDS  GRIDS  REAL *4  0.0164 

^116  1  !  ITO  MINIMAL  2-WAY  TRAVEL  TIME  INTEGER*2 

0117  1  !  MGSOP  MGS  PROVINCE  NUMBER  INTEGER* 2 

0118  1  !  N  #  OF  DEPTH/VELOCITY  PAIRS  INTEGER* 2 


C-MT.  2 


0119 

1 

i 

NN 

#  OF  DEPTH/VELOCITY  PAIRS 

INTEGER 

D120 

1 

t 

PI 

MATHEMATICAL  CONSTANT  PI 

REAL *4 

0121 

1 

j 

SNDATE 

(9) 

DATE  SYS  PARMS  LAST  UPDATED 

BYTE 

0122 

1 

i 

SNT IME 

(8) 

TIME  SYS  PARMS  LAST  UPDTAED 

BYTE 

0123 

1 

( 

SYDATE 

(9) 

CURRENT  DATE  READ  FROM  SYSTEM 

BYTE 

0124 

1 

i 

SYTIME 

(8) 

CURRENT  TIME  READ  FROM  SYSTEM 

BYTE 

0125 

1 

i 

TMP 

TEMPERATURE 

REAL *4 

0126 

1 

i 

* 

UMKZ 

BOTTOM  BACK  SCATTERING  COEF. 

REAL *4 

0127 

1 

i 

« 

WS 

WIND  SPEED 

REAL *4 

0128 

1 

i 

Z 

(50) 

DEPTH  OF  POINT  OF  SOUND  SPEED 

REAL *4 

0129 

1 

i 

ZZ 

(50) 

DEPTH  OF  POINT  OF  SOUND  SPEED 

REAL *4 

0130 

1 

0131 

1 

INTEGER *2  I TO , MGSOP , N, NN 

0132 

1 

REAL*4 

BDF , B IOP , C ( 50 ) , CC ( 50 ) ,CS,DEG, 

EL, F, GRDS 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

2148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 

0161 

0162 

0163 

0164 

0165 

0166 

0167 

0168 

0169 

0170 

0171 

0172 

0173 

Q174 

Jl75 

0176 

0177 


3.1415927 


-28.0 


1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 


REAL *4  P I , TMP , UMKZ , WS , Z ( 5  0 ) ,ZZ(50) 

BYTE  SYDATE ( 9 ) ,SYTIME(8) , BTDATE ( 9 ) , BTTIME ( 8 ) 

BYTE  SNDATE ( 9 ) , SNT IME ( 8 ) 

DATA  PI , DEG, GRDS/3. 1415927, 57. 2957795, 0.0164/ 

DATA  UMKZ/ -2 8./ 

COMMON  /SVP/  F , N , Z , C , EL ,MGSOP , BDF , WS , CS , TMP , BIOP , 
UMKZ , PI , DEG , GRDS , I TO , ZZ, CC, NN, 

SYDATE , SYTIME , BTDATE , BTTIME , SNDATE , SNT IME 

- SVP-END - 

INCLUDE  ' SVPl . INC ' 

- SVPl - 


VARBL  S I ZE 


BUFFER 

DS 

J20 

NS 

NSN 

SLNTY 

VS 


(224) 

(30) 


(30) 


PURPOSE  TYPE  RANGE 

HISTORICAL  DATA  FILE  BUFFER  REAL *4 

HISTORICAL  DEPTH  REAL *4 

#  OF  DEEP  OCEAN  DEPTH/VEL  PAIRS  INTEGER* 2 
TOTAL  #  OF  PAIRS  IN  HISTORICAL  INTEGER* 2 
MONTH  NUMBER  (1=JAN.,ETC)  INTEGER* 2  1  TO  12 

SALINITY  REAL *4 

HISTORICAL  VELOCITY  REAL *4 


REAL *4  BUFFER, DS, SLNTY, VS 
INTEGER* 2  J20,NSN,NS 

COMMON  /SVPl/  J20 ,BUFFER(224) , NSN, SLNTY, DS(30) ,VS(30) , NS 
- END  svpi - 

VARBL  SIZE  PURPOSE  TYPE  RANGE 

ICHC  MENU  SELECTION  INTEGER* 2  +-1  TO  +-11 

IFL  FOR  DEFINE  FILES  INTEGER* 2 

IPRINT  PRINT  FLAG  INTEGER* 2  +-1 

***  VARIABLES  NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMONS  *** 

INTEGER* 2  ICHC, IFL, IPRINT 


40 


- PRELIMINARIES - 

!  RESET  FORMAT  FIELD  LENGTH  F 
CALL  ERRSET(63, .TRUE. , .FALSE. , .FALSE. , .FALSE. ,15)  !  ERROR  MESSAG 
CALL  ICLR  !  CLEAR  SCREEN 


WRITE( 5,900) 


■PREDICTION  TYPE  SELECT I ON- 
!  PROMPT  FOR  PREDICTION  TYPE 


C-  VS*.  3 


0178 

0179 

1)180 

0181 

0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 

0201 

0202 

0203 

0204 

0205 

<3206 

J207 

0208 

0209 

0210 

0211 

0212 

0213 

0214 

0215 

0216 

0217 

0218 

0219 

0220 

0221 

0222 

0223 

0224 

0225 

0226 

0227 

0228 

0229 

0230 

0231 

0232 

n233 

^234 

0235 

0236 


READ( 5,1200) IANS  !  OPERATIONAL  OR  FORCAST 

IF( IANS . LT . -2 .OR . IANS . GT . 2 .OR. IANS .EQ. 0 )  GO  TO  40  !  INVALID 
IF(IANS.GT.O)  THEN 
IPRINT  =  * Y ' 

ELSE 

IPRINT  3  'N' 

IANS  =  IANS  *  -1 
END  IF 


!  POSITIVE  RESPONSE 
!  HARDCOPY 
!  NEGATIVE  RESPONSE 
!  NO  HARDCOPY 

!  MAKE  POSITIVE  FOR  FUTURE  US 
!  END  IF  BLOCK 


400 


450 


- PREDICTION  TYPE  PERFORMED - 

IF  (IANS.EQ.l)  THEN  !  OPERATIONAL  SELECTED 

CALL  CLOSE ( 2 )  !  CLOSE  FILE  2 

OPEN(UNIT=2, NAME =' NEWS VP . DAT; 1' ,TYPE=* UNKNOWN' ,  !  OPEN  I  FILE 
ACCESS=' DIRECT' , FORM= ' UNFORMATTED ' , RECORDS I ZE3 3 4 0 ) 


I ANS=1 

CALL  ENVIRN( IPRINT) 
CALL  CLOSE ( 2) 

OPEN (UN I T= 2 , NAME = ' NEWS VP , 


SET  IANS 

UPDATE  ENVIRN  DATA 
CLOSE  FILE  2 
DAT ;  1 '  , TYPE= ' UNKNOWN ' 


ACCESS^ ' D I RECT '  , FORM3 ' UNFORMATTED ' , RECORDS I ZE=  34  0) 

ELSE  !  FORCAST I NG  SELECTED 

CALL  CLOSE ( 2 )  !  CLOSE  FILE  2 

OPEN(UNIT32,NAME3' NWHIST.DAT; 1 ' ,TYPE3' UNKNOWN' ,  !  OPEN  FILE 
ACCESS3' DIRECT' , FORM3 ' UNFORMATTED ' , RECORDS  I ZE3 340 ) 


SET  IANS 

UPDATE  FORCST  DATA 
CLOSE  FILE  2 


IANS 3 2 

CALL  FORCST ( IPRINT) 

CALL  CLOSE ( 2 ) 

OPEN(UNIT=2,NAME3'NWHIST.DAT;l' , TYPE3 ' UNKNOWN ' ,  !  OPEN  FILE 

ACCESS3 'DIRECT*  , FORM3 ' UNFORMATTED ' , RECORDS  I ZE3 34 0 ) 

END  IF  !  END  IF  BLOCK 


50 


CALL  ICLR 
WRITE ( 5 , 1100 ) 

WRITE (5,1150) 

READ ( 5 , 1200 )  ICHC 
IF ( ICHC.LT.-ll.OR. ICHC.GT.il. 
IF( ICHC.GT.0)  THEN 
IPRINT  3  'Y' 

ELSE 

IPRINT  3  'N' 

ICHC  3  ICHC  *  -1 
END  IF 


- MENU  SELECTION - 

!  CLEAR  SCREEN 
!  PROMPT  FOR  MENU  CHOICE 
!  PROMPT  FOR  MENU  CHOICE 
!  READ  OPERATOR  CHOICE 
.  ICHC.EQ.0)  GO  TO  50  !  INVALID 
!  POSITIVE  RESPONSE 
!  HARDCOPY 
!  NEGATIVE  RESPONSE 
!  NO  HARDCOPY 

!  MAKE  POSITIVE  FOR  FUTURE  US 
!  END  IF  BLOCK 


IF  (ICHC.EQ.l)  CALL  ACTV26 ( IPRINT) 
IF  ( ICHC.EQ. 2 )  CALL  ACTVLP ( IPRINT) 
IF  (ICHC.EQ. 3)  CALL  VDS ( IPRINT) 

IF  (ICHC.EQ. 4)  CALL  OTHERS ( IPRINT ) 
IF  (ICHC.EQ. 5)  CALL  PBB( IPRINT) 

IF  (ICHC.EQ. 6)  CALL  PSSV( IPRINT) 

IF  (ICHC.EQ. 7)  GO  TO  400 
IF  (ICHC.EQ. 8)  GO  TO  450 
IF  (ICHC.EQ. 9)  CALL  SVPTRC 
IF  (ICHC.EQ. 10)  CALL  RAXIN( IPRINT) 
IF  (ICHC.NE.11)  THEN 
GO  TO  50 
ELSE 

CALL  CLOSE ( 2 ) 

STOP  'EXIT  SIMAS’ 


PERFORM  MENU  SELECTION - 

!  SQS-26  PRED/EQPT  SETTINGS 
!  LAMPS  PERF  PRED  (ACTIVE) 

!  AN/SQS-35  VDS  (ACTIVE) 

!  OTHER  UNITS 
!  PASSIVE  BROADBAND  (ALL) 

!  PASSIVE  NARROWBAND  (ALL) 

!  UPDATE  &  DO  OPERATIONAL 
!  UPDATE  &  DO  FORECASTING 
!  RAYTRACE  ROUTINE 
!  RAYMODE 

!  IF  NOT  EXIT  THEN 
!  RETURN  TO  MENU  CHOICES 
l  IF  CHOICE  WAS  11 
!  CLOSE  FILE  2 
!  EXIT  SIMAS 


C-HT.  H 


!  END  IF  BLOCK 


0237 

0238 

0239 

0240 

0241 

0242 

0243 

0244 

0245 

0246 

0247 

0248 

0249 

0250 

0251 

0252 

0253 

0254 

0255 

0256 

0257 

0258 

0259 

0260 

0261 


END  IF 


! - FORMAT  STATEMENTS - 

900  FORMATC  SIMAS  (SONAR  IN-SITU  MODE  ASSESSMENT  SYSTEM)' 

1  ////,4X, 'SELECT  PREDICTION  TYPE  DESIRED:' 

2  //, 4X, ' 1  =  OPERATIONAL’ 

3  //,4X, ' 2  =  FORECASTING' 

4  ///5X, ' ****  ENTER  YOUR  CHOICE  ****', T60,'  ’,$) 

1100  FORMATC  SIMAS  (SONAR  IN-SITU  MODE  ASSESSMENT  SYSTEM)'/ 


1  ///, 4X, ' 1  =  AN/SQS-26  PR EDICT IONS /EQUIPMENT  SETTINGS  (ACTIVE)' 

2  //, 4X, '2  =  LAMPS  PERFORMANCE  PREDICTIONS  (ACTIVE)' 

3  //, 4X, '3  =  AN/SQS-35  VDS  (ACTIVE)’ 

4  // , 4X , '4  =  OTHER  UNITS' 

5  //, 4X, ' 5  =  PASSIVE  BROADBAND  (ALL  SYSTEMS)' 

6  //, 4X, '6  =  PASSIVE  NARROWBAND  (ALL  SYSTEMS)') 

1150  FORMAT ( 

1  / ,  4X ,  '  7  =  UPDATE  OPERATIONAL  DATA  S.  DO  OPERATIONAL  PREDICTIONS’ 

2  //, 4X, '8  =  UPDATE  FORECASTING  DATA  &  DO  FORECASTING  PREDICTIONS' 

3  //, 4X, '9  =  RAYTRACE  ROUTINE' 

4  //, 3X, '10  =  RAYMODE' 

5  //, 3X, 'll  =  EXIT  SIMAS'/// 

6  5X , ' ****  ENTER  YOUR  CHOICE  ****', T60,'  ',$) 

1200  FORMAT ( 1 3 ) 

END 


<r-  Hr.s~ 


0001 
■0002 
0003 
0004 
0005 
0006 
0007 
0008 
0009 
0010 
0011 
0012 
0013 
0014 
0015  1 

0016  1 
0017  1 

0018  1 
0019  1 

0020  1 
0021  1 
0022  1 
0023  1 

0024  1 

0025  1 

0026  1 
0027  1 

0028  1 
)029  1 

0030 
0031 
0032 
0033 
0034 
0035 
0036 
0037 
0038 
0039 
0040 
0041 
0042 
0043 
0044 
0045 
0046 
0047 
0048 
0049 
0050 
0051 
0052 
0053 
0054 
0055 
)056 
0057 
0058 
0059 


SUBROUTINE  SMOOTH ( NBT , NDLYR) 

PROLOGUE : 

MODULE  NAME:  SMOOTH 

AUTHOR:  STEPHEN  LAFLEUR,  CODE  3333,  NUSC/NLL 
DATE:  18  SEP  84 

FUNCTION:  SUBROUTINE  SMOOTH  WILL  SMOOTH  THE  XBT  DATA 
WITHOUT  MODIFYING  THE  LAYER  DEPTH  POINT. 
INPUTS:  PARAMETERS  PASSED  IN  AND  VARIABLES  IN  COMMONS. 
OUTPUTS:  SMOOTHED  XBT  DATA 
MODULES  CALLED:  NONE 
CALLED  BY:  XBT 


INCLUDE 

' DTV. INC' 

VARBL 

SIZE 

PURPOSE 

TYPE 

RANGE 

D 

(25) 

DEPTH 

REAL *4 

DD 

(25) 

DEPTH 

REAL *4 

NNBT 

NUMBER  OF  BATHETHERMAL 

INTEGER* 2 

T 

(25) 

TEMPERATURE 

REAL *4 

TT 

(25) 

TEMPERATURE 

REAL *4 

VEL 

(25) 

VELOCITY 

REAL *4 

INTEGER 

*2  NNBT 

REAL *4 

D,DD,T,TT, VEL 

COMMON 

/DTV/  D( 25 ) ,T ( 25 ) , VEL( 25 ) , 

DD (25) , TT (25) , NNBT 

_  pxjD  nrnTr  — 

VARBL 

SIZE 

PURPOSE 

TYPE  RANGE 

Dl 

DIFFERENCE  IN  DEPTHS 

REAL *4 

D2 

DIFFERENCE  IN  DEPTHS 

REAL *4 

VO 

INTERPOLATED  SOUND  SPEED 

.REAL *4 

VI 

DELTA  SOUND  SPEED 

REAL *4 

V2 

DELTA  SOUND  SPEED 

REAL *4 

VEL1 

(25) 

VELOCITY 

REAL *4 

I 

COUNTER 

INTEGER*2 

J 

COUNTER 

INTEGER*2 

NBT 

NUMBER  OF  3T  POINTS 

INTEGER*2 

NDLYR 

BT  LAYER'S  POSITION  IN  ARRAY 

INTEGER* 2 

***  VARIABLES  NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMON  *** 

INTEGER* 2  I ,J, NBT, NDLYR 
REAL  *  4  D1 , D2 , VEL1 , VO , Vl , V2 

DIMENSION  VEL1 ( 25 ) 


DO  320  1=2, NBT- 1 
D1=D ( I )-D( 1-1) 

D2=D( I+l)-D( I ) 

V1=VEL( 1-1 ) -VEL( I ) 

V2=VEL( I+1)-VEL( I ) 

IF(Dl.LE.D2)  THEN 
V0=VEL(I )+V2*Dl/D2 
VEL1 { I ) = ( VEL ( I - 1 ) +VEL ( I ) +V0 ) /3 
ELSE  !  PREVIOUS 


SMOOTH  XBT  DATA - 

SMOOTH  MODIFIED  DATA 
DEPTH  DIFF  THIS  DEPTH  &  NEXT 
DEPTH  DIFF  THIS  &  PREVIOUS 
SOUND  SPEED  DIFF  THIS  &  PREVIOUS 
SOUND  SPEED  DIFF  THIS  &  NEXT 
PREVIOUS  <  NEXT  DEPTH 
INTERPOLATE  SOUND  SPEED 

!  SMOOTHED  SOUND  SPEED 
>  NEXT  DEPTH 


C-He.i 


0060 

V0=VEL ( I )-Vl 

*D2/D1  !  INTERPOLATE  SOUND  SPEED 

■9061 

VEL1 ( I ) = ( V0+VEL ( I ) +VEL ( I +1 ) ) /3  !  SMOOTHED 

SOUND  SPEED 

0062 

END  IF 

!  END  IF  BLOCK 

0063 

IF(I.EQ.NDLYR) 

VEL1 ( I ) =VEL ( I )  !  LEAVE  LAYER 

POINT 

0064 

320 

CONTINUE 

!  END  DO  LOOP 

0065 

DO  350  J=2 , NBT- 1 

!  BEGIN  DO  LOOP 

0066 

VEL(J)=VEL1(J) 

!  INSERT  SMOOTHED 

DATA 

0067 

350 

CONTINUE 

!  END  DO  LOOP 

0068 

RETURN 

!  BACK  TO  CALLING 

ROUTINE 

0069 

END 

!  END  SUBROUTINE 

COMMAND  QUALIFIERS 

FORTRAN  /CHECK=ALL/LIST/SHOW=( INCLUDE, NOMAP)  [ LAFLEUR] SMOOTH. F7 7 

/CHECK= ( BOUNDS , OVERFLOW , UNDERFLOW ) 

/DEBUG* ( NOSYMBOLS , TRACEBACK ) 

/STANDARD* ( NOSYNTAX , NOSOURCE_FORM ) 

/SHOW* ( NOPREPROCESSOR, INCLUDE , NOMAP ) 

/F77  /NOG  FLOATING  /1 4  /OPTIMIZE  /WARNINGS  /NOD  LINES  /NOCROSS  REFERENCE 


COMPILATION  STATISTICS 

Run  Time:  1.22  seconds 

Elapsed  Time:  1.91  seconds 

Page  Faults:  333 

Dynamic  Memory:  126  pages 


C-HC.& 


0001 
0002 
0003 
0004 
0005 
0006 
0007 
0008 
0009 
0010 
0011 
0012 
0013 
0014 
0015  1 

0016  1 
0017  1 

0018  1 
0019  1 

0020  1 
0021  1 
0022  1 
0023  1 

0024  1 

0025  1 

0026  1 
0027  1 

0028  1 
9029  1 

■00  30 
0031  1 

0032  1 

0033  1 

0034  1 

0035  1 

0036  1 

0037  1 

0038  1 

0039  1 

0040  1 

0041  1 

0042  1 

0043  1 

0044  1 

0045  1 

0046  1 

0047  1 

0048  1 

0049  1 

0050  1 

0051  1 

0052  1 

0053  1 

0054  1 

0055  1 

1056  1 

■4057  1 

0058  1 

0059  1 


SUBROUTINE  SSP(INSSP) 


PROLOGUE: 

MODULE  NAME:  SSP 

AUTHOR:  S.  LAFLEUR  &  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  5/84  &  5/84  (FORTRAN  77) 

FUNCTION:  SUBROUTINE  SSP  IS  USED  FOR  MANUAL  ENTRY  OF  SSP  DATA 
(DEPTH  AND  VELOCITY  VALUES). 

INPUTS:  OPERATOR  INPUT  OF  DATA.  VARIABLES  IN  COMMONS. 
OUTPUTS:  CRT  PROMPTING  MESSAGES  TO  OPERATOR. 

MODULES  CALLED:  EDITBT, I CLR, METRIC 
CALLED  BY:  KEYPCH 


INCLUDE  ’DTV.INC' 


DTV 


I 


VARBL 

SIZE 

PURPOSE 

TYPE  RANGE 

D 

(25) 

DEPTH 

REAL*4 

DD 

(25) 

DEPTH 

REAL* 4 

NNBT 

NUMBER  OF  BATHETHERMAL 

INTEGER* 2 

T 

(25) 

TEMPERATURE 

REAL *4 

TT 

(25) 

TEMPERATURE 

REAL *4 

VEL 

(25) 

VELOCITY 

REAL *4 

INTEGER 

*2  NNBT 

REAL *4 

D , DD, T , TT , VEL 

COMMON 

/DTV/  D(25) ,T(25) , VEL (25) 

, DD  (  2  5 ) , TT ( 2  5 ) , NNBT 

END  DTV 


INCLUDE  'S' VP.  INC' 

- SVp 


VARBL 

SIZE 

PURPOSE 

TYPE 

RANGE 

BDF 

BOTTOM  DEPTH  IN  FATHOMS 

REAL *4 

BIOP 

BIOLOGICAL  BACK  SCATTERING  COEF 

REAL *4 

BTDATE 

(9) 

DATE  OF  LAST  BT  INPUT 

BYTE 

BTTIME 

(8) 

TIME  OF  LAST  BT  INPUT 

BYTE 

C 

(50) 

VELOCITY  (PAIRED  WITH  Z  FOR  SVP) 

REAL *4 

cc 

(50) 

VELOCITY  (PAIRED  WITH  ZZ  FOR  SVP 

) REAL *4 

cs 

SOUND  VELOCITY  AT  SURFACE 

REAL *4 

DEG 

TEMPERATURE  (DEG) 

REAL *4 

57.2957795 

EL 

LAYER  DEPTH 

DATA 

F 

FREQUENCY 

REAL* 4 

GRDS 

GRIDS 

REAL *4 

0.0164 

ITO 

MINIMAL  2 -WAY  TRAVEL  TIME 

INTEGER*  2 

MGSOP 

MGS  PROVINCE  NUMBER 

INTEGER* 2 

N 

#  OF  DEPTH/VELOCITY  PAIRS 

INTEGER* 2 

NN 

#  OF  DEPTH/VELOCITY  PAIRS 

INTEGER* 2 

PI 

MATHEMATICAL  CONSTANT  PI 

REAL*4 

3 . 1415927 

SNDATE 

(9) 

DATE  SYS  PARMS  LAST  UPDATED 

BYTE 

SNTIME 

(8) 

TIME  SYS  PARMS  LAST  UPDTAED 

BYTE 

SYDATE 

(9) 

CURRENT  DATE  READ  FROM  SYSTEM 

BYTE 

SYTIME 

(8) 

CURRENT  TIME  READ  FROM  SYSTEM 

BYTE 

TMP 

TEMPERATURE 

REAL *4 

UMKZ 

BOTTOM  BACK  SCATTERING  COEF. 

REAL *4 

-28.0 

WS 

WIND  SPEED 

REAL *4 

Z 

(50) 

DEPTH  OF  POINT  OF  SOUND  SPEED 

REAL*4 

ZZ 

(50) 

DEPTH  OF  POINT  OF  SOUND  SPEED 

REAL* 4 

C-  V.  i 


0060 

1061 

0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 

0081 

0082 

0083 

0084 

0085 

0086 

0087 

)088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 

0101 

0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 

0111 

0112 

0113 

0114 

1115 

0116 

0117 

0118 


1  INTEGER*2  I TO , MGSOP , N , NN 

1  REAL  *  4  BDF , B I OP , C { 5  0 ) , CC (50), CS , DEG , EL , F , GRDS 

1  REAL  *  4  P I , TMP , UMKZ , WS , Z ( 5  0 ) ,ZZ(50) 

1  BYTE  SYDATE ( 9 )  , SYTIME ( 8  )  , BTDATE ( 9 ) , BTTIME ( 8 ) 

1  BYTE  SNDATE ( 9 ) , SNT IME ( 8 ) 

1  DATA  PI, DEG, GRDS/3. 1415927, 57. 2957795, 0.0164/ 

1  DATA  UMKZ/-28 . / 

1 

1  COMMON  /SVP/  F, N, Z,C, EL, MGSOP, BDF, WS,CS, TMP, BIOP, 

1  1  UMKZ, PI , DEG, GRDS, ITO , ZZ , CC , NN, 

1  2  SYDATE, SYTIME, BTDATE, BTTIME, SNDATE, SNT I ME 

1  ! - SVP -END - 

INCLUDE  'SVP1.INC' 

1  ! - SVP1 - 

1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

1  ! -  -  -  - 

1  <  BUFFER  (224)  HISTORICAL  DATA  FILE  BUFFER  REAL *4 

1  !  DS  (30)  HISTORICAL  DEPTH  REAL *4 

1  !  J20  #  OF  DEEP  OCEAN  DEPTH/VEL  PAIRS  INTEGER* 2 

1  !  NS  TOTAL  #  OF  PAIRS  IN  HISTORICAL  INTEGER *2 

1  !  NSN  MONTH  NUMBER  (WAN.,  ETC)  INTEGER*2  1  TO  12 

1  !  SLNTY  SALINITY  REAL *4 

1  !  VS  (30)  HISTORICAL  VELOCITY  REAL *4 

1 

1  REAL *4  BUFFER, DS, SLNTY, VS 

1  INTEGER*2  J20,NSN,NS 

1 

1  COMMON  /SVP1/  J20,BUFFER(224) , NSN, SLNTY, DS(30) ,VS(30) , NS 

1  ! - END  SVPl - 


VARBL  SIZE  PURPOSE 


TYPE  RANGE 


I 

I ERROR 

INSSP 

J 

JANS 

L 


COUNTER  INTEGER* 2 

ERROR  FLAG  FORM  METRIC  INTEGER* 2 

SSP  TYPE  SELECTED  BY  OPERATOR  INTEGER* 2  . 

COUNTER  INTEGER* 2 

OPERATOR  RESPONSE  FOR  LAST  SSP  INTEGER* 2 
OPERATOR  RESPONSE  FOR  EDIT  SSP  INTEGER* 2  Y  OR  N 


***  VARIABLES  NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMONS  *** 


INTEGER*2  I , IERROR, INSSP, J 

10  IERROR  =  0 

CALL  ICLR 
WRITE( 5 , 2050 ) 

READ (5, 10 50)  JANS 
IF( JANS.EQ. ' Y' )  THEN 
DO  250  1=1, NN 
Z(I)=ZZ(I) 

C( I)=CC( I) 

250  CONTINUE 

N=NN 
GOTO  75 
END  IF 

40  CALL  ICLR 

WRITE( 5,2250) 

DO  50  J=1 , 50 

WRITE( 5,1310)  J 


JANS , L 

; 

SET  METRIC  ERROR  FLAG 

; 

CLEAR  SCREEN 

j 

USE  LAST  SSP  PROMPT 

i 

OPERATOR  RESPONSE 

1 

****USE  PROFILE  SAVED 

i 

FROM  LAST  RUN  **** 

i 

STORE  DEPTH 

i 

STORE  VELOCITY 

i 

END  DO  LOOP 

i 

NUMBER  OF  SSP  POINTS 

i 

GO  TO  OUTPUT 

i 

END  IF  BLOCK 

; 

CLEAR  SCREEN 

i 

INPUT  SSP 

| 

DO  50  TIMES 

i 

WRITE  LOOP  COUNTER 

C-V7.Z 


0119 

0120 

0121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

9147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 


READ (5,1300)  Z(J),C(J) 

I F ( J . GT . 1 . AND . Z ( J ) . LE . 1 . ) GO  TO  60 
IF(C(J) .LE.100. )  GOTO  40 
50  CONTINUE 

J=51 

60  N=J-1 

75  WRITE( 5 , 1380 ) 

WRITE (5 , 1400 ) 

WRITE( 5,1420)  (I,Z(I) ,C(I) , 1=1 ,N) 

WRITE(5f 1500) 

READ( 5,1050)  L 

IF(L.EQ.'Y')  CALL  EDITBT( INSSP ,N, Z,C 
DO  100  1  =  1, N 

zzd)-z(i) 

CC(I)=C(I) 

100  CONTINUE 

NN=N 

CALL  METR I C ( INSSP , ZZ , CC , N, Z , C , SLNTY , 

I F ( I ERROR . EQ . 1 )  GO  TO  10 
BDF=Z(N)/6. 

RETURN 

i - FORMAT  STATEMENTS - 

1050  FORMAT ( Al ) 

1300  FORMAT ( 2F10 , 2 ) 

1310  FORMAT ( T5 , 1 5 , T22 , ' ****'  ,T32,$) 

1380  FORMAT ( 1H  /T26 OPERATOR  INPUT  DATA') 

1400  FORMAT (//T22, 'NO. ' ,T32, 'DEPTH' ,T42, 

1  ' SOUND '/T4 2, 'SPEED'/) 

1420  FORMAT (T2 3 , 1 2 , T32 , F7 . 1 , T42 , F6 . 1 ) 

1500  FORMAT (1H0/1H$,4X, 'DO  YOU  WISH  TO  EDIT  THE  DATA?  YES  OR  NO’,T60) 
2050  FORMATC  DO  YOU  WANT  TO  USE  THE  LAST  PROFILE?  ’,$) 

2250  FORMAT (T20, ’ENTER  SOUND  SPEED  PROFILE  (50  POINTS  MAX)' 

1  /T20 , '  IN  METRIC  AND/OR  ENGLISH  UNITS’ 

2  /T20 , '  (AN  EXTRA  <CR>  TERMINATES  ENTRIES)’ 

3  //T32, 'DEPTH' ,T42, ' SOUND' /T42, 'SPEED'/) 

END 


READ  DEPTH  &  TEMP 
CHECK  FOR  LAST  ENTRY 
INVALID  LOOP  BACK 
END  DO  LOOP 
SET  COUNTER  TO  51 
#  OF  SSP  =  COUNTER  -  1 
INPUT  DATA  TITLE  PROMPT 
PARAMETER  TITLES 
DEPTH  AND  TEMP  OR  SS 
CHECK  ENTRIES  FOR  ERRORS 
EDIT  DATA  RESPONSE 
!  CORRECT  SSP  DATA 
****  SAVE  PROFILE  **** 
STORE  DEPTH 
STORE  VELOCITY 
END  DO  LOOP 
NUMBER  OF  SSP  POINTS 
/S( 1 ) , I ERROR)  !  METRIC  CALC 
ERROR  IN  DATA  INPUT 
BOTTOM  DEPTH  IN  FATHOMS 
RETURN  TO  CALLING  ROUTINE 


C-H7.J 


17-Dec-1984  15:05:5* 
17-Dec-1984  15:05:5 


J51  SUBROUTINE  SVPGRF  ( INPBDF  > 

0002 

0003  1  PROLOGUE: 

0004  1  MODULE  NAME:  SVPGRF 

0005  I  AUTHOR:  JOHN  VALLEY,  S.  LAFLEUR,  &  W.  WACHTER,  CODE  3333,  NUSC/NLL 
0006  !  DATE:  1977,  19S2  (REDESIGN),  &  11/83  (FORTRAN  77) 

0007  !  FUNCTION:  SUBROUTINE  SVPGRF  PRODUCES  A  HARDCOPY  GRAPHIC  OUTPUT 

0008  !  OF  DEEP  AND  SHALLOW  SVFS. 

0009  !  INPUTS:  HARD  COPY  SELECTION.  PARAMETERS  PASSED  IN.  VARIABLES 

0010  !  IN  COMMONS. 

0011  !  OUTPUTS:  CRT  PROMPTING  MESSAGES  TO  OPERATOR 

0012  !  MODULES  CALLED:  ICLR , INSERT , OUTPUT 

0013  I  CALLED  BY:  ENVIRN ,FORCST 

0014  l 

0016  !  ALGORITHMS  USED: 

0017  ! 

0018  !  MINIMUM  SOUND  SPEED  FOR  AXIS  LABEL  =  INTEGER* 2  VALUE  OF 

0019  !  (ACTUAL  MINIMUM  SPEED  -  10)  /  50 

0020  ! 

0021  !  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =:  =  =  =  =  =  =  =:  =  =  =  =  =  =  =  =  =  = 

0022  ! 

0023  INCLUDE  'DHST. INC' 

0024  1  ! - DHST - 

0025  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0026  1  I -  -  -  - 

'’''27  1  !  SCHNLD  SOUND  CHANNEL  LAYER  DEPTH  REAL*4 

£8  1  I 

0029  1  REAL* 4  SCHNLD 

0030  1 

0031  1  COMMON  /DHST/  SCHNLD 

0032  1  ! - DHST  END - 

0033  INCLUDE  'ENVN.INC' 

0034  1  ! - ENVN - 

0035  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0036  1  !  - -  -  -  - 

0037  1  !  BIO  (2)  BIOLOGICAL  BACK  SCATTERING  REAL* 4  -57.  &  -47. 

0038  1  !  DLYR  LAYER  DEPTH  REAL *4 

0039  1  !  MGS  MGS  PROVINCE  INTEGER*2 

0040  1 

0041  1  REAL*4  BIO, DLYR 

0042  1  INTEGER* 2  MGS 

0043  1  DATA  BIO/ -57. ,-47. / 

0044  1 

0045  1  COMMON  /ENVN/  BIO (2) , DLYR, MGS 

0046  1 

0047  1  ! - END  ENVN - 

0048  INCLUDE  'GRF.INC' 

0049  1  ! - GRF - 

0050  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0051  1  !  - -  -  -  - 

0052  1  !  DBT  (25)  DEPTH  OF  DEPTH/VEL  PAIR  REAL*4 

0053  1  1  IANS  PREDICTION  TYPE  INTEGER*2  -2  TO  +2 

O'' 54  11  ILYR  INDEX  FOR  LAYER  DEPTH  INTEGER*2 

45  1  1  INBT  OPERATOR  ENTERED  #  OF  BT  POINTS  INTEGER*2 

0056  1  !  ISVF  LATEST  OR  HISTORICAL  BT  FLAG  INTEGER* 2  1  OR  2 

0057  1  1  12000  SVF  INDEX  FOR  2000  FT  DEPTH  INTEGER* 2 


C-V?./ 


SVPGRF 

&8 
0059 
0060 
0061 
0062 
0063 
0064 
0065 
0066 
0067 
0068 
0069 
0070 
0071 
0072 
0073 
0074 
0075 
0076 
0077 
0078 
0079 
0080 
0081 
0082 
0083 

P  '■'34 

35 
0036 
0037 
0038 
0089 
0090 
0091 
0092 
0093 
0094 
0095 
0096 
0097 
0093 
0099 
0100 
0101 
0102 
0103 
0104 


1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 


!  VEST 


(25) 


VELOCITY  FOR  DEPTH  PAIR  REAL*4 


17-Dec-1984  15 :05s 5 
17-Dec- 1984  15:05:5 

REAL*4 


REAL*4  DBT,VBT 

INTEGER* 2  IANS , ILYR , INBT, ISVP , 12000 

COMMON  /GRF/  IANS , ISVP , ILYR , 12000 , INBT, DBT( 25 ) ,VBT( 25 ) 

- END  GRF - 

--LOC - 


INCLUDE  ' LOC . INC ' 
VARBL  SIZE  PURPOSE 


INDX 

LAT  ( 4 ) 
LONG  ( 4 ) 
NMAREA  (20) 
NOC 
RCZ 


SSP  INDEX 
LATITUDE 
LONGITUDE 
AREA  OCEAN  NAME 
NUMBER  OF  OCEAN 
RANGE  TO  CONVERG.  ZONE  REAL*4 


TYPE 

INTEGER* 2 
INTEGER* 2 
INTEGER* 2 
BYTE 

INTEGER* 2 


RANGE 


REAL*4  RCZ 

INTEGER* 2  INDX , LAT , LONG , NOC 
BYTE  NMAREA (20) 

COMMON  /LOC/  LAT(4) ,L0NG(4) , NOC , INDX, RCZ , NMAREA 

- END  LOc - 


INCLUDE  'OCEANS. INC' 


OCEANS 


!  VARBL  SIZE 

i 


PURPOSE 


!  IOCEAN  (50) 


ARRAY  OF  NAMES  OF  OCEANS 


TYPE 


DATA 


1 

2 

3 

4 


INTEGER* 2  IOCEAN 
DIMENSION  IOCEAN ( 50 ) 

DATA  IOCEAN/ 'NO' , 'RT' , 'H  ' , 'PA' , 'Cl' ,  'FI 
' NO ' , ' RT '  ,  '  H  ' , 'AT' f'LA' , '  NT' f'IC' , '  O', 
' ME ' , ' DI ' , ' TE ' , ' RR ' , ' AN ' , ' EA ' , ' N  ' ,'SE' , 
'IN' ,'DI' ,'AN' ,'  O' ,'CE' ,'AN' ', 
'NO' ,'RW' ,'EG' ,'IA' ,'N  ','SE', 'A  ', 


r'C 

CE'  , 
A  ', 


,  'OC' , 'EA' ,'N 
AN'  , 


r 

'  / 


COMMON  /OCEANS/  IOCEAN 


END  OCEANS 


INCLUDE  ' SVF . INC ' 


-SVF- 


0105 

1 

i 

VARBL 

SIZE 

PURPOSE 

TYPE 

0106 

1 

i 

— 

— 

0107 

1 

i 

BDF 

BOTTOM  DEPTH  IN  FATHOMS 

REAL *4 

0108 

1 

i 

BIOP 

BIOLOGICAL  BACK  SCATTERING  COEF 

REAL* 4 

0109 

1 

i 

BTDATE 

(9) 

DATE  OF  LAST  BT  INPUT 

BYTE 

0110 

1 

i 

BTTIME 

(8) 

TIME  OF  LAST  BT  INPUT 

BYTE 

O’  11 

1 

i 

C 

(50) 

VELOCITY  (PAIRED  WITH  Z  FOR  SVF) 

REAL* 4 

v  h 

1 

i 

CC 

(50) 

VELOCITY  (PAIRED  WITH  ZZ  FOR  SVP)REAL*4 

0113 

1 

i 

CS 

SOUND  VELOCITY  AT  SURFACE 

REAL* 4 

0114 

1 

i 

DEG 

TEMPERATURE  (DEG) 

REAL* 4 

RANGE 


57.2957795 


C'^-2. 


SVPGRF 


17-Dec-1934  15:05:5 
17-Dec- 1934  15:05:5 


0145 

0146 

0147 

0143 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0153 

0159 

0160 

0161 

0162 


1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 


15 

1 

1 

EL 

LAYER  DEPTH 

DATA 

0116 

1 

1 

F 

FREQUENCY 

REAL* 4 

0117 

1 

1 

GRDS 

GRIDS 

REAL*4 

0113 

1 

1 

ITO 

MINIMAL  2 -WAY  TRAVEL  TIME 

INTEGER* 2 

0119 

1 

1 

MGS  OP 

MGS  PROVINCE  NUMBER 

INTEGER*2 

0120 

1 

1 

N 

#  OF  DEPTH /VELOCITY  PAIRS 

INTEGER* 2 

0121 

1 

1 

NN 

#  OF  DEPTH /VELOCITY  PAIRS 

INTEGER *2 

0122 

1 

1 

PI 

MATHEMATICAL  CONSTANT  PI 

REAL*4 

0123 

1 

1 

SNDATE 

(9) 

DATE  SYS  PARMS  LAST  UPDATED 

BYTE 

0124 

1 

1 

SNTIME 

(3) 

TIME  SYS  PARMS  LAST  UPDTAED 

BYTE 

0125 

1 

1 

SYDATE 

(9) 

CURRENT  DATE  READ  FROM  SYSTEM 

BYTE 

0126 

1 

1 

SYTIME 

(3) 

CURRENT  TIME  READ  FROM  SYSTEM 

BYTE 

0127 

1 

1 

TMF 

TEMPERATURE 

REAL*4 

0123 

1 

1 

UMKZ 

BOTTOM  BACK  SCATTERING  COEF. 

REAL* 4 

0129 

1 

1 

WS 

WIND  SPEED 

REAL *4 

0130 

1 

1 

Z 

(  50) 

DEPTH  OF  POINT  OF  SOUND  SPEED 

REAL* 4 

0131 

1 

1 

77 

LA  LA 

(  50) 

DEPTH  OF  POINT  OF  SOUND  SPEED 

REAL*4 

0132 

1 

0133 

1 

INTEGER* 2  ITO , MGSOP  , N , NN 

0134 

1 

REAL *4 

BDF,BIOP,C( 50)  ,CC( 50)  ,CS  ,DEG,‘ 

EL, F, GRDS 

0135 

1 

REAL* 4 

PI ,TMP, UMKZ, WS, 2(50) ,Z2(50) 

0136 

1 

BYTE 

SYDATE ( 9 ) ,SYTIME( 3) , BTDATE ( 9 ) 

, BTTIME ( 3 ) 

0137 

1 

BYTE 

SNDATE ( 9 ) , SNTIME (  3 ) 

0133 

1 

DATA 

PI, DEG, GRDS/ 3. 1415927,57.2957795,0.0164/ 

0139 

1 

DATA 

UMKZ/ -23. / 

0140 

1 

r "  41 

1 

COMMON 

/SVP/  F,N,Z,C, EL, MGSOP, BDF,WS,CS 

,TMP,BIOP, 

42 

1 

1 

UMKZ, PI, DEG, GRDS , ITO, ZZ,CC,NN, 

0143 

1 

2 

SYDATE , SYTIME , BTDATE , BTTIME , SNDATE , SNTIME 

0144 

1 

1 

— 

- SVP -END - 

0.0164 


3.1415927 


_  7 


23.0 


INCLUDE  ' SVP1 . INC ' 


-SVF1- 


VARBL  SIZE 


PURPOSE 


TYPE 


RANGE 


BUFFER 

DS 

J20 

NS 

NSN 

SLNTY 

VS 


(  224) 
(30) 


(  30) 


HISTORICAL  DATA  FILE  BUFFER 
HISTORICAL  DEPTH 
#  OF  DEEP  OCEAN  DEPTH /VEL  PAIRS 
TOTAL  #  OF  PAIRS  IN  HISTORICAL 
MONTH  NUMBER  (1=JAN.,ETC) 
SALINITY 

HISTORICAL  VELOCITY 


REAL*4 
REAL *4 
INTEGER* 2 
INTEGER* 2 
INTEGER *2 
REAL* 4 
REAL *4 


1  TO  12 


REAL* 4  BUFFER , DS , SLNTY , VS 

INTEGER* 2  J20,NSN,NS 


COMMON  /SVF1/  J20 , BUFFER! 224 )  , NSN , SLNTY ,DS ( 30 )  fVS(30) ,NS 

- END  SVF1 - 


0163 

!  VARBL 

SIZE 

PURPOSE 

TYPE  RA) 

0164 

1  - 

— 

— 

0165 

!  CMIN 

MINIMUM  SOUND  SPEED 

REAL *4 

0166 

!  FTER 

CONVERT  FEET  TO  RASTER  UNITS 

REAL *4 

0167 

!  I 

LOOP  COUNTER 

INTEGER* 2 

<"  68 

!  IBLNK 

BLANK  SPACES 

DATA 

v  49 

!  IC 

(50) 

VELOCITY  IN  RASTERS 

INTEGER*! 

0170 

1  ICOPY 

NUMBER  OF  HARDCOPIES  REQUESTED 

BY  OPERATOR 

INTEGER* 2 

0171 

!  IDDAT 

(  14) 

'OPERATION  AREA  FORECAST  AREA' 

LABEL 

DATA 

c-4?-  3 


SVPGRF 


17-Dec-19B4  15:05;5' 
17-Dec-1984  15i05;5' 


^  Jl  2 

1  IDF 

END  POINTER  FOR  JSPDAT  ARRAY 

INTEGER* 2 

0173 

!  IDEFSC 

SOUND  CHANNEL  DEPTH 

INTEGER *2 

0174 

!  IGTYP 

GRAPH  TYPE  DEPENDENT  ON  BOTTOM  DEPTH 

INTEGER* 2 

0175 

1  IJECT 

OPERATOR  RESPONSE  FOR  GRAPHIC  OUTPUT 

INTEGER* 2 

0176 

[  INC  I 

RASTER  DIFF  BETWEEN  DEPTH  LABEL  HEIGHTS 

INTEGER* 2 

0177 

!  INPBDF 

INPUTTED  BOTTOM  DEPTH  IN  FATHOMS 

INTEGER* 2 

017B 

!  IRCZ 

RANGE  TO  CONVERGENCE  ZONE 

INTEGER* 2 

0179 

!  ISTRT 

BOTTOM  LINE  RASTER  HT  (DEEP  PROFILE  GRAPH) 

INTEGER *2 

0180 

1  ITOT 

TOTAL  NUMBER  OF  DEPTH  LINES  MINUS  ONE 

INTEGER* 2 

0181 

!  IUD 

STARTING  POINTER  FOR  JSPDAT  ARRAY 

INTEGER* 2 

0182 

!  IXNOW 

X  COORDINATE  IN  RASTERS 

INTEGER* 2 

0183 

!  IXSTRT 

LOOP  COUNTER 

INTEGER* 2 

0184 

!  IY 

FACTOR  FOR  DEEP  SVP  HORIZONTALS 

REAL* 4 

0185 

!  IYPLOT 

Y  COORDINATE  IN  RASTERS 

INTEGER *2 

0186 

!  IYPOS 

Y  COORDINATE  IN  RASTERS 

INTEGER* 2 

0187 

1  IYSPOT 

Y  COORDINATE  IN  RASTERS 

INTEGER* 2 

0188 

!  IZ 

(50) 

DEPTH  IN  RASTERS 

INTEGER* 2 

0189 

!  16 

POINTER  FOR  IDDAT  ARRAY 

INTEGER* 2 

0190 

!  J 

LOOP  COUNTER 

INTEGER* 2 

0191 

i  JBTMDP 

BOTTOM  DEPTH  IN  FATHOMS 

INTEGER* 2 

0192 

!  JCMAX 

MAXIMUM  SOUND  SPEED  ON  GRAPHS 

INTEGER* 2 

0193 

!  JCMIN 

MINIMUM  SOUND  SPEED  ON  GRAPHS 

INTEGER* 2 

0194 

!  JF 

MAXIMUM  DEPTH  OF  THE  GRAPH 

INTEGER* 2 

0195 

1  JJ 

MAX  SOUND  SPEED  FOR  AXIS  LABEL 

INTEGER* 2 

0196 

!  JNBT 

NUMBER  OF  BATHETHERMALS 

INTEGER* 2 

0197 

!  JS 

DEPTH  BETWEEN  LABELED  DEPTHS 

INTEGER* 2 

'"98 

!  JSPDAT 

(30) 

'HISTORICAL  LATEST  XBT  KEYPUNCHED  LABELS 

DATA 

£9 

i  JWIND 

WIND  SPEED 

INTEGER* 2 

0200 

!  K 

LOOP  COUNTER 

INTEGER* 2 

0201 

!  L 

LOOP  COUNTER 

INTEGER *2 

0202 

!  LAYER 

LAYER  DEPTH 

INTEGER*2 

0203 

i  M 

LOOP  COUNTER 

INTEGER* 2 

0204 

!  NL 

(8) 

LABEL  'DEPTH  FT' 

DATA 

0205 

!  NNN 

LOOP  COUNTER 

INTEGER* 2 

0206 

1  RMONTH 

(12) 

ARRAY  OF  NAMES  OF  MONTHS 

DATA 

0207 

1  RSTEP 

IDEAL  RASTER  DIFFERENCE  BETWEEN  LINES 

REAL* 4 

0208 

!  SCHMXD 

SOUND  CHANNEL  MAXIMUM  DEPTH 

REAL *4 

0209 

!  THEBD 

BOTTOM  DEPTH  IN  FEET 

REAL *4 

0210 

1  XA 

FACTOR  FOR  SHALLOW  SVP  VERICALS 

REAL* 4 

0211 

!  XX 

(  50) 

FACTOR  FOR  VELOCITY  IN  RASTERS 

REAL*  4 

0212 

!  XI 

FACTOR  FOR  DEEP  SVP  VERICALS 

REAL*4 

0213 

!  YA 

FACTOR  FOR  SHALLOW  SVP  HORIZONTALS 

REAL* 4 

0214 

!  YY 

(50) 

FACTOR  FOR  DEPTH  IN  RASTERS 

REAL *4 

0215 

!  YI 

FACTOR  FOR  DEEP  SVP  HORIZONTALS 

REAL* 4 

0216 

!  Z2000 

BOTTOM  DEPTH 

REAL *4 

0  217  ! 

0218 

!  ***  VARIABLES  NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMONS 

*** 

0219 

0220 

0221 

INTEGER* 2  IDDAT 

INTEGER*2  I f IC , ICOPY , IDF , IDEPSC , IGTYP , IJECT , INCI , 

INPBDF 

0222 

INTEGER* 2  IRCZ , ISTRT , ITOT , IUD , IXNOW , IXSTRT , I Y , IYPLOT 

0223 

INTEGER*2  IYPOS , IYSPOT , IZ , 16 , J , JBTMDP , JCMAX , JCMIN 

,  JF ,  J  J 

0224 

r-75 

v  26 

INTEGER* 2  JNBT, JS , JWIND ,K,L, LAYER ,M, NNN 

INTEGER* 2  JSPDAT , NL , IBLNK 

REAL* 4  CMIN,FTER, RSTEP, SCHMXD, THEBD, XA, XX, XI , YA,YY, YI ,Z2000 

0227 

0228 

DIMENSION  IC ( 50 ) , IZ ( 50 ) ,XX(50) ,YY<50) ,JSPDAT(30) , 

IDDAT (14) 

SVPGRF 
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0230 
0231 
0232 
0233 
0234 
0235 
0236 
0237 
0238 
0239 
0240 
0241 
0242 
0243 
0244 
0245 
0246 
0247 
0248 
0249 
0250 
0251 
0252 
0253 
0254 
0  755 
£6 
0257 
0258 
0259 
0260 
0261 
0262 
0263 
0264 
0265 
0266 
0267 
0268 
0269 
0270 
0271 
0272 
0273 
0274 
0275 
0276 
0277 
0278 
0279 
0280 
0281 
0^82 
*3 
0284 
0235 


1 

2 


1 


DIMENSION  NL( 8) 

DIMENSION  RMONTH (12) 

DATA  RMONTH/ 'JAN  ','FEB  ' , ' MAR  ' , ' APR  ' , 

' MAY  ' , ' JUN  ' , ' JUL  ' , ' AUG  ' , 

' SEP  ' , ' OCT  ' , ' NOV  ' , ' DEC  ' / 

DATA  NL/'D' , 'E' ,'F' , 'T' , 'H' ,'  ','F','T'/ 

DATA  IDDAT/'OP' ,'ER' ,'AT' ,'I0' ,'N  ' , ' AR ' , ' EA' , ' FO ' , 
1 ' ST ' , '  A' ,  'RE' , 'A  ' / 


DATA  JSPDAT/ 'H' , ' I' , 
'  L '  ,  '  A '  , '  T '  ,  '  E '  ,  '  S  '  , 
2'K' , 'E' , '  Y ' , 'F' , 'U' 
DATA  IBLNK/ '  '/ 


A' 


r 


'L' 


'RE' 


t 


'CA' 


r 


=========================== =====PRELIMINARIES================: 

SCHMXD  =  1000.  !  MAX  SOUND  CHANNEL  DEPTH 

Z2000=200Q .  !  BOTTOM  DEPTH 

IF ( 6 . *BDF . LT .  Z  2  0  0  0  )  Z2000=6 . *BDF!  SET  MINIMUM  BOTTOM  DEPTH 
CALL  INSERT (N ,Z,C,Z2000,I200G)  !  INSERT  DEPTH/VELOCITY  POINT 


- DEEP  PROFILE  GRAPH  TYPE  FROM  TRUE  BOTTOM  DEPTH 

THEBD=6.0*BDF  !  BOTTOM  DEPTH  IN  FEET 

IF(THEBD.GE.O. .AND. THEBD.LE. 12000. )  IGTYP=1  !  TYPE  1  <12,000 

IF(THEBD. GT. 12000. .AND. THEBD.LE. 16000. )  IGTYP=2  !  TYPE  2  <16,000 
IF(THEBD. GT. 16000. )  IGTYP=3  !  TYPE  3  >16,000 


- INITALIZE  CONVERSION  FACTORS 

SCHNLD=10000 .  !  SOUND  CHANNEL  DEPTH 

CMIN=C ( 1 )  !  MINIMUM  SOUND  SPEED 

IF(ILYR.LT.N-l)  THEN  !  LESS  THAN  NEXT  TO  LAST 

DO  53  I=ILYR+1 ,N-1  !  LAYER  DEPTH+1  TO  #  OF  PAIRS 

IF(C(I) .LE.C(I+1) .AND. SCHNLD.EQ. 10000. )  SCHNLD=Z(I)  !  RESET 


IF ( C ( I ) . LT . CMIN )  CMIN=C ( I ) 
53  CONTINUE 

END  IF 

CALL  OUTPUT (INPBDF) 

JJ=IIFIX( ( CMIN-10 . ) / 50 . ) 

JCMIN=50*JJ 

JCMAX=JCMIN+300 


IF  (IGTYP.EQ.l)  THEN 
FTER=70 . /3000 . 
ISTRT=63 
INCI=70 
RSTEP=70 . / 3 . 
IT0T=12 
JF=12000 
JS=3000 
END  IF 

IF  (IGTYP.EQ.2)  THEN 
FTER=70 . /4000 . 
ISTRT=63 
INCI=70 
RSTEP=70 . /4 . 
IT0T=16 
JF=16000 
JS=4000 


MINIMUM  FOR  MIN  SOUND  SPEED 
END  DO  LOOP 

END  IF  BLOCK 

PRINT  SVF  INFO  FOR  CHECKING 

!  MAX  SOUND  SD  FOR  AXIS  LABI 
I  MIN  SOUND  SPEED  ON  GRAPHS 
!  MAX  SOUND  SPEED  ON  GRAPHS 

SET  FARMS  FOR  DRAWING  GRAPHS 
!  BOTTOM  DEPTH  <  12,000  FEET 
!  CONVERT  FEET  TO  RASTER  UNITS 
I  BOTTOM  LINE  RASTER  HT 

I  RASTER  DIFF:  DEPTH  LABEL  HTS 

I  RASTER  DIFF  BETWEEN  LINES 
I  TOTAL  #  OF  DEPTH  LINES -1 
!  MAXIMUM  DEPTH  OF  THE  GRAPH 
!  DEPTH  BETWEEN  LABELED  DEPTHS 
!  END  IF  BLOCK 

I  BOTTOM  DEPTH  <  16,000  FEET 
!  CONVERT  FEET  TO  RASTER  UNITS 
i  BOTTOM  LINE  RASTER  HT 
!  RASTER  DIFF: DEPTH  LABEL  HTS 
!  RASTER  DIFF  BETWEEN  LINES 
l  TOTAL  #  OF  DEPTH  LINES- 1 
!  MAX  DEPTH  OF  THE  GRAPH 
i  DEPTH  BETWEEN  LABELED  DEPTHS 


C-W'S* 


SVPGRF 
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&6 

0287 

0288 

0289 

0290 

0291 

0292 

0293 

0294 

0295 

0296 

0297 

0298 

0299 

0300 

0301 

0302 

0303 

0304 

0305 

0306 

0307 

0308 

0309 

0310 

0311 

0314 

0315 

0316 

0317 

0318 

0319 

0320 

0321 

0322 

0323 

0324 

0325 

0326 

0327 

0328 

0329 

0330 

0331 

0332 

0333 

0334 

0335 

0336 

0337 

0333 

HS 

0341 

0342 


END  IF 

IF  (IGTYF.EQ.3)  THEN 
FTER=70 . / 5000 . 

ISTRT=49 
INCI=42 
RSTEF=42 .  /  3 . 

IT0T=21 
JF =21000 
JS=3000 
END  IF 
WRITE( 5,106) 

READ (5,950)  IJECT 
IFdJECT.NE. 'Y' )  GOTO  999 


!  END  IF  BLOCK 

!  BOTTOM  DEPTH  >  16,000  FEET 
!  CONVERT  FEET  TO  RASTER  UNITS 
!  BOTTOM  LINE  RASTER  HT 
!  RASTER  DIFF:  DEPTH  LABEL  HTS 
!  RASTER  DIFF  BETWEEN  LINES 
!  TOTAL  #  OF  DEPTH  LINES- 1 
i  MAXIMUM  DEPTH  OF  THE  GRAPH 
!  DEPTH  BETWEEN  LABELED  DEPTHS 
t  END  IF  BLOCK 
!  PROMPT  FOR  GRAPHIC  OUTPUT 
1  RESPONSE  FOR  GRAPHICS 
!  NO  GRAPHICS  WANTED,  RETURN 


===  =  =  =  =  =  =  =  —  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =D0  GRAPHICS  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  = 
CALL  INITT(  3 )  !  PREPARE  TK4025  FOR  GRAPHICS 

I  0 <  =X<  =639  0<=Y<=419  RASTERS 


DO  110  1=0, ITOT 

YI=RSTEP*FLOATI < I ) 
IY=IIFIX(YI) 
IYPLOT=IY+ISTRT 
IF ( IY/ INCI . EQ . IIFIX ( YI ) 
CALL  LNTYPE(l) 

CALL  CONECT( 55 , IYPLOT 
ELSE 

CALL  LNTYFE ( 2 ) 

CALL  CONECT( 63 , IYPLOT 
END  IF 

110  CONTINUE 


DRAW  THE  DEEP  PROFILE - 

1  DO  HORIZONTALS 
l  #  OF  RASTERS  SO  FAR 
S  INTEGER* 2  COUNTERPART 
!  Y  COORDINATE  IN  RASTERS 
INCI)  THEN  !  HORIZONTALS  AND  TICS 

i  TYPE  OF  LINE  _ 

255, IYPLOT) I  DRAW  LINE  BETWEEN  PTS 
!  HORIZONTALS  ONLY 

1  TYPE  OF  LINE  . 

2 5 5, IYPLOT)!  DRAW  LINE  BETWEEN  PTS 
!  END  IF  BLOCK 
!  END  DO  LOOP 


120 


DO  120  K=63 , 255 ,32  !  DO  VERICALS 

XI =FLOATI ( K )  !  INTEGER *2  COUNTERPART 

IF(  (FLOATI(K)+l.  )/64.  .NE.  (X1+-1.  )/64.  )  THEN!  VERTICALS  AND  TICS 

CALL  LNTYPE ( 2 )  !  TYPE  OF  LINE  . 

CALL  CONECT (K,ISTRT,K, IYPLOT )! DRAW  LINE  BETWEEN  2  PTS 
ELSE  !  VERTICALS  ONLY 

CALL  LNTYPE ( 1 )  !  TYPE  OF  LINE  _ 

CALL  C0NECT(K,ISTRT,K,IYFL0T+7) !DRAW  LINE  BETWEEN  2  PTS 
END  IF  !  END  IF  BLOCK 

CONTINUE  !  END  DO  LOOP 


130 


DO  130  K=1,N  !  . 64=RASTERS / ( FT/ SEC ) 

XX( K) = . 64* ( C(K) -FLOATI ( JCMIN) ) +63 .  !  63=RASTER  COORD.  OF  JCMIN 
YY ( K ) =343 . - ( FTER*Z (K ) )  !  343=RASTER  HEIGHT  OF  0  DEPTH 

IC(K)=IIFIX(XX(K) )  !  VELOCITY  IN  RASTER  UNITS 

IZ(K) =IIFIX( YY(K) )  !  DEPTH  IN  RASTER  UNITS 

CONTINUE  !  END  DO  LOOP 

CALL  CONECT ( ICC  1) ,IZ( 1) ,IC( 2) ,IZ( 2) )  !  DRAW  LINE  BETWEEN  PTS 


140 


DO  140  M=3,N 

CALL  DRAW(IC(M) ,IZ(M) ) 
CONTINUE 


!  FOR  NUMBER  OF  PAIRS 
!  DRAW  DEEP  SVF 
!  END  DO  LOOP 


DO  150  M=63 ,343 , 14 


-DRAW  SHALLOW  PROFILE - 
!  DO  HORIZONTALS 


SVPGRF 

*3 

0344 

0345 

0346 

0347 

0348 

0349 

0350 

0351 

0352 

0353 

0354 

0355 

0356 

0357 

0358 

0359 

0360 

0361 

0362 

0363 

0364 

0365 

0366 

0367 

0368 

0^69 

>0 

0371 

0372 

0373 

0374 

0375 

0376 

0377 

0378 

0379 

0380 

0381 

0382 

0383 

0384 

0385 

0386 

0387 

0388 

0389 

0390 

0391 

0392 

0393 

0394 

0395 

0^96 

P 

0398 
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17-Dec-1984 
17- Dec-1984 
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YA=*FL0ATI  ( M) 

IF( (M-63) /28.EQ. ( IIFIX(  YA) 
CALL  LNTYPE ( 1 ) 

C0NECT( 423 ,M,623 ,M) 


!  REAL  COUNTERPART 
-63)/ 28)  THEN!  HORIZONTALS  AND  TICS 
1  TYPE  OF  LINE  _ 


LNTYPE ( 2 ) 

CONECT (431, M, 623 ,M) 


150 


160 


170 


180 


CALL 
ELSE 
CALL 
CALL 
END  IF 
CONTINUE 
M=IIFIX(YA) 

DO  160  NNN=431 ,643,32 
XA=FLOATI ( NNN ) 

IF (  ( NNN-431 ) /64 .  NE. ( I IFIX(XA)  ■ 
CALL  LNTYPE ( 2 ) 

CALL  CONECT( NNN ,63 ,NNN ,M) 
ELSE 

CALL  LNTYPE ( 1 ) 

CALL  CONECT (NNN, 63, NNN, M+7) 
END  IF 
CONTINUE 

DO  170  NNN=1, 12000 
IC ( NNN) =IC ( NNN) +368 
YY ( NNN) =343 . - . 14*Z (NNN ) 
IZ(NNN) =IIFIX( YY(NNN) > 
CONTINUE 


ONLY 


!  DRAW  LINE  BETWEEN  2  PTS 
!  HORIZONTALS  ONLY 

!  TYPE  OF  LINE  . 

!  DRAW  LINE  BETWEEN  2  PTS 
!  END  IF  BLOCK 
!  END  DO  LOOP 
!  INTEGER* 2  COUNTERPART 

!  DO  VERTICALS 
!  REAL  COUNTERPART 
■431)/ 64)  THEN  !  VERTICALS 

!  TYPE  OF  LINE  . 

!  DRAW  LINE  BETWEEN  PTS 
!  VERTICALS  AND  TICS 

!  TYPE  OF  LINE  _ 

!  DRAW  LINE  BETWEEN  PTS 
!  END  IF  BLOCK 
!  END  DO  LOOP 

!  CONVERT  C  AND  Z  TO  RASTER 
!  368=RASTER  SHIFT  .-DEEP-SHALLOW 
!  . 14=RASTERS/ (FOOT  OF  DEPTH) 

!  343=RASTER  HEIGHT  OF  0  DEPTH 
!  END  DO  LOOP 


CALL  CONECT ( IC( 1 ) , IZ ( 1 ) , IC ( 2 ) , IZ ( 2 ) ) !  DRAW  LINE  BETWEEN  2  PTS 


DO  180  NNN=3, 12000 

CALL  DRAW ( IC ( NNN ) , IZ ( NNN ) ) 
CONTINUE 


!  DO  PROFILE 
!  DRAW  SHALLOW  PROFILE 
!  !  END  DO  LOOP 


IF  RESULTANT  PROFILE  WAS  FORMED  BY  MERGING  WITH  AN  XBT, 

_PLOT  THE  RAW  XBT  DATA _ 

IF ( INBT.NE. 0 . AND . ISVF . NE. 5 )  THEN 
WRITE( 5 ,191 ) 


DO  192  M= 1 , INBT 

IF ( DBT ( M ) . GT .2000. ) GOTO  193 


!  NEW  XBT  GIVEN 
WRITE  RAW  DATA  IN  SHALLOW  SVF 
FOR  NUMBER  OF  BTS 
IF  DEPTH  OF  BT  >  MAX, 


OUT 


XX(M) = . 64* ( VBT( M) -FLOATI ( JCMIN) ) +431 . 0 !  FACTOR 


192 

193 


IC ( M ) = I IFIX ( XX ( M ) ) 

YY (M) =343 . - . 14*DBT ( M) 
IZ (M) =IIFIX( YY ( M) ) 
CONTINUE 
JNBT=M-1 
DO  194  K=1 , 2 


!  VELOCITY  IN  RASTERS 
!  FACTOR 

!  DEPTH  IN  RASTERS 
!  END  DO  LOOP 
!  RESET  NUMBER  OF  BTS 
!  DO  TWICE 


194 


195 


CALL  SYMBOL ( ( IC (K) -2 ) ,(IZ(K)-2) ,0,1, 'X' )  !  PLOT  SYMBOL 
CONTINUE  !  END  DO  LOOP 

IF( JNBT.GE.3)  THEN  !  IF  NUMBER  OF  BT  >  =  3 

DO  195  M=3 , JNBT  !  DO  UNTIL  NUMBER  OF  BTS 

CALL  SYMBOL( (IC(M)-2) ,(IZ(M)-2) ,0,1, 'X' )  !  PLOT  SYMBOL 
CONTINUE  !  END  DO  LOOP 

END  IF  !  END  IF  BLOCK 

CALL  LNTYPE ( 2 )  !  TYPE  OF  LINE  _ 

CALL  CONECT ( IC ( 1 ) , IZ ( 1 ) , IC ( 2 ) , IZ ( 2 ) )  !  DRAW  LINE  BETWEEN  2  PTS 

CALL  LNTYPE ( 2 )  !  TYPE  OF  LINE  _ 

DO  198  M=3 , JNBT  !  DO  UNTIL  NUMBER  OF  BTS 
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bo 

0401 

0402 

0403 

0404 

0405 

198 

| 

CALL  DRAW(IC(M) ,IZ(M) ) 
CONTINUE 

CALL  LNTYFE ( 1 ) 

END  IF 

1  DRAW  TO  THESE  COORDINATES 
!  END  DO  LOOP 
!  TYPE  OF  LINE 
•  END  IF  BLOCK 

rnuTr1  cDpmc  ntr  nnimi  r,-D  7\  ouc 

—  inn.  jrL£.Uo  Ur  Duln  Liriivrrlo - 

0406 

DO  205  IXSTRT=48 , 416 , 368 

i 

LOOP  COUNTER 

0407 

IXN  OW = IXSTRT 

i 

X  COORDINATE  IN  RASTERS 

0408 

DO  200  L= JCMIN , JCMAX, 100 

i 

FOR  ALL  SOUND  SPEEDS 

0409 

CALL  MOVE( IXNOW, 363 ) 

j 

MOVE  TO  THESE  COORDS 

0410 

CALL  INUMBR ( L  ,  4 ) 

i 

WRITE  NUMBER 

0411 

IXNOW= IXNOW+64 

i 

RESET  X  COORDINATE 

0412 

200 

CONTINUE 

i 

END  DO  LOOP 

0413 

205 

CONTINUE 

i 

END  DO  LOOP 

0414 

0415 

| 

r  a  nrr  TT-nr  corviTTr  tt  nuarmc 

— inn  JrKUr  lijiL  Utiiirlrua 

0416 

IYSP0T=349 

i 

Y  COORDINATE  IN  RASTERS 

0417 

DO  210  J=0 , JF, JS 

i 

LABEL  DEEP  PROFILE  DEPTH 

0418 

CALL  MOVE( 16 , IYSPOT) 

i 

MOVE  TO  THESE  COORDS 

0419 

CALL  INUMBR (J, 5) 

i 

WRITE  NUMBER 

0420 

IYSFOT=IYSPOT-INCI 

i 

RESET  Y  COORDINATE 

0421 

210 

CONTINUE 

! 

END  DO  LOOP 

0422 

IYP0S=349 

i 

Y  COORDINATE  IN  RASTERS 

0423 

DO  220  J=0, 2000, 200 

i 

LABEL  SHALLOW  PROFILE  DEPTH 

0424 

CALL  MOVE ( 392, IYPOS) 

! 

MOVE  TO  THESE  COORDS 

0425 

CALL  INUMBR (J, 4) 

! 

WRITE  NUMBER 

IYPOS =IYP0S-28 

! 

RESET  Y  CORDINATE 

h 

220 

CONTINUE 

i 

END  DO  LOOP 

0428 

0429 

i - 

- PUT  the  ACTUAL 

SVP  DATA  BETWEEN  THE  GRAPHS 

0430 

CALL  MOVE( 264 ,343 ) 

i 

MOVE  TO  THESE  COORDS 

0431 

CALL  TEXT (12, 'DEPTH  SPEED') 

i 

WRITE  TEXT  STRING 

0432 

IYF0S=329 

i 

Y  COORDINATE  IN  RASTER 

0433 

M=I2000 

; 

SET  M  TO  12000 

0434 

IF ( N . LE .21)  M=N 

i 

RESET  M  IF  #  OF  PAIRS <=21 

0435 

DO  230  K=1 ,M 

1 

DO  FOR  MAX  OF  21  ENTRIES 

0436 

IZ(K)=IIFIX(Z(K) ) 

i 

DEPTH  IN  RASTERS 

0437 

IC (K) =IIFIX(C(K) ) 

i 

VELOCITY  IN  RASTERS 

0438 

CALL  MOVE (264, IYPOS) 

i 

MOVE  TO  THESE  COORDS 

0439 

CALL  INUMBR ( IZ  ( K ) , 5 ) 

i 

WRITE  NUMBER 

0440 

CALL  MOVE (3 20, IYPOS) 

i 

MOVE  TO  THESE  COORDS 

0441 

CALL  INUMBR ( IC ( K ) , 4 ) 

i 

WRITE  NUMBER 

0442 

IYFQS= IYPOS -14 

i 

RESET  Y  COORDINATE 

0443 

230 

CONTINUE 

i 

END  DO  LOOP 

0444 

IF(M.EQ.N)  GOTO  255 

i 

NUMBER  OF  PAIRS  <=  21 

0445 

DO  240  M=1 , 3 

i 

DO  THREE  TIMES 

0446 

CALL  CONECT ( 287 , IYFOS+2 , 287 , 

IYPOS ) 1  DRAW  LINE  BETWEEN  PTS 

0447 

CALL  CONECT( 336, IYPOS+2, 336, 

IYPOS)!  DRAW  LINE  BETWEEN  PTS 

0448 

IYPOS =IYP0S-7 

RESET  Y  COORDINATE 

0449 

240 

CONTINUE 

END  DO  LOOP 

0450 

IYFOS=IYPOS-7 

RESET  Y  COORDINATE 

0451 

NNN=N- ( 18-12000 ) 

RESET  NNN 

0452 

IF(NNN.GT.N)  GOTO  255 

IF  NNN  >  NUMBER  OF  PAIRS 

r  -<53 

DO  250  L=NNN,N 

DO  UNTIL  NUMBER  OF  PAIRS 

V  M 

IZ ( L) =IIFIX( Z ( L ) ) 

DEPTH  IN  RASTERS 

0455 

IC ( L) =IIFIX( C ( L ) ) 

VELOCITY  IN  RASTERS 

0456 

CALL  MOVE (264, IYPOS) 

MOVE  TO  THESE  COORDS 

SVPGRF 
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CALL  INUMBRt IZ(L) ,5) 

i 

WRITE  NUMBER 

0*58 

CALL  MOVE (320, I YPOS ) 

i 

MOVE  TO  THESE  COORDS 

r 

0459 

CALL  INUMBR ( IC ( L ) ,  4 ) 

i 

WRITE  NUMBER 

0460 

IYP0S=IYP0S-14 

i 

RESET  Y  COORDINATE 

0461  250  CONTINUE 

i 

END  DO  LOOP 

0462  255  CONTINUE 

i 

END  DO  LOOP 

0463 

0464  !  — 

--PUT  ON  THE  TOP  LINE  OF  TEXT- 

— 

0465 

CALL  M0VE( 0,413) 

i 

MOVE  TO  THESE  COORDS 

0466 

CALL  TEXT (  35 , ' DATE  AND  TIME  OF 

IN- 

-SITU  UPDATE  IN  ' ) (WRITE  TEXT 

0467 

16= ( IANS-1 ) *7+1 

1 

POINTER  FOR  IDDAT  ARRAY 

0460 

CALL  M0VE( 280 ,413 ) 

i 

MOVE  TO  THESE  COORDS 

0469 

CALL  TEXT ( 14 , IDDAT ( 16 ) ) 

i 

WRITE  TEXT  STRING 

0470 

CALL  MOVE( 424 , 413 ) 

i 

MOVE  TO  THESE  COORDS 

0471 

IF( IANS.NE.2)  THEN 

i 

OPERATION  PREDICTION  TYPE 

0472 

CALL  TEXT ( 1 , BTDATE ( 1 ) ) 

i 

WRITE  TEXT  STRING 

0473 

CALL  M0VE( 432 , 413 ) 

i 

MOVE  TO  THESE  COORDS 

0474 

CALL  TEXT( 1 , BTDATE ( 2 ) ) 

i 

WRITE  TEXT  STRING 

0475 

CALL  MOVE (440,413) 

i 

MOVE  TO  THESE  COORDS 

0476 

CALL  TEXT( 1 ,BTTIME( 1 ) ) 

i 

WRITE  TEXT  STRING 

0477 

CALL  M0VE( 448 , 413 ) 

t 

MOVE  TO  THESE  COORDS 

0478 

CALL  TEXT ( 1 , BTTIME ( 2 ) ) 

i 

WRITE  TEXT  STRING 

0479 

CALL  M0VE( 456 ,413 ) 

i 

MOVE  TO  THESE  COORDS 

0480 

CALL  TEXT( 1 , BTTIME ( 4 ) ) 

i 

WRITE  TEXT  STRING 

0481 

CALL  M0VE( 464 ,413 ) 

i 

MOVE  TO  THESE  COORDS 

0482 

CALL  TEXT ( 1 , BTTIME ( 5 ) ) 

i 

WRITE  TEXT  STRING 

0483 

CALL  MOVE( 472 , 413 ) 

i 

MOVE  TO  THESE  COORDS 

>4 

CALL  TEXT( 2 , ' Z  ' ) 

i 

WRITE  TEXT  STRING 

0485 

CALL  MOVE( 488 ,413 ) 

i 

MOVE  TO  THESE  COORDS 

0436 

CALL  TEXT ( 1 , BTDATE ( 4 ) ) 

i 

WRITE  TEXT  STRING 

04B7 

CALL  MOVE( 496 ,413 ) 

i 

MOVE  TO  THESE  COORDS 

0488 

CALL  TEXT ( 1 , BTDATE ( 5 ) ) 

i 

WRITE  TEXT  STRING 

0489 

CALL  MOVE( 504 ,413 ) 

i 

MOVE  TO  THESE  COORDS 

0490 

CALL  TEXT ( 1 , BTDATE ( 6 ) ) 

i 

WRITE  TEXT  STRING 

0491 

CALL  M0VE( 512 , 413 ) 

i 

MOVE  TO  THESE  COORDS 

0492 

CALL  TEXT( 1 , '  ' ) 

i 

WRITE  TEXT  STRING 

0493 

CALL  MOVE( 520 ,413 ) 

i 

MOVE  TO  THESE  COORDS 

0494 

CALL  TEXT( 1 ,BTDATE( 8 ) ) 

i 

WRITE  TEXT  STRING 

0495 

CALL  M0VE( 528,413) 

i 

MOVE  TO  THESE  COORDS 

0496 

CALL  TEXT ( 1 , BTDATE ( 9 ) ) 

i 

WRITE  TEXT  STRING 

0497 

ELSE 

i 

FORECAST  PREDICTION  TYPE 

0498 

CALL  TEXT( 4 ,RM0NTH( NSN) ) 

i 

WRITE  TEXT  STRING 

0499 

END  IF 

i 

END  IF  BLOCK 

0500 

0501  !-• 

--PUT  ON  THE  SECOND  LINE  OF  TEXT 

0502 

IF ( ISVF .EQ . 5)  THEN 

i 

NUMBER  OF  OCEAN  =  -1 

0503 

CALL  M0VE( 24,399) 

i 

MOVE  TO  THESE  COORDS 

0504 

CALL  TEXT (20, NMAREA ) 

I 

WRITE  TEXT  STRING 

0505 

END  IF 

i 

END  IF  BLOCK 

0506 

IF(NOC.EQ.l)  THEN 

I 

NUMBER  OF  OCEAN  =  1 

0507 

CALL  MOVE (32,399) 

j 

MOVE  TO  THESE  COORDS 

0508 

CALL  TEXT (2 0,1 OCEAN) 

1 

WRITE  TEXT  STRING 

0509 

END  IF 

i 

END  IF  BLOCK 

0510 

IF ( NOC .EQ . 2 )  THEN 

j 

NUMBER  OF  OCEAN  =  2 

)l 

CALL  MOVE (24, 399) 

i 

MOVE  TO  THESE  COORDS 

0512 

CALL  TEXT( 20 ,IOCEAN( 11 ) ) 

1 

WRITE  TEXT  STRING 

0513 

END  IF 

i 

END  IF  BLOCK 

C-HZ-I 
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IF ( NOC .EQ . 3 )  THEN 

i 

NUMBER  OF  OCEAN  =  3 

0515 

CALL  MOVE( 48,399) 

i 

MOVE  TO  THESE  COORDS 

0516 

CALL  TEXT( 20 , IOCEAN( 21 ) ) 

i 

WRITE  TEXT  STRING 

0517 

END  IF 

i 

END  IF  BLOCK 

0518 

IF ( NOC . EQ . 4 )  THEN 

i 

NUMBER  OF  OCEAN  =  4 

0519 

CALL  MOVE( 88,399) 

i 

MOVE  TO  THESE  COORDS 

0520 

CALL  TEXT( 20 , IOCEAN ( 31 ) ) 

i 

WRITE  TEXT  STRING 

0521 

END  IF 

i 

END  IF  BLOCK 

0522 

IF ( NOC .EQ . 5 )  THEN 

l 

NUMBER  OF  OCEAN  =  5 

0523 

CALL  MOVE( 80,399) 

i 

MOVE  TO  THESE  COORDS 

0524 

CALL  TEXT (20, IOCEAN ( 41 ) ) 

i 

WRITE  TEXT  STRING 

0525 

END  IF 

i 

END  IF  BLOCK 

0526 

IF ( ISVP . NE . 5 ) THEN 

0527 

CALL  MOVE{ 200 , 399 ) 

i 

MOVE  TO  THESE  COORDS 

0528 

CALL  TEXT( 9 , ' SSP  AREA; ' ) 

i 

WRITE  TEXT  STRING 

0529 

CALL  MOVE (272,399) 

i 

MOVE  TO  THESE  COORDS 

0530 

CALL  INUMBR ( INDX , 2 ) 

j 

WRITE  NUMBER 

0531 

CALL  MOVE( 184,399) 

l 

MOVE  TO  THESE  COORDS 

0532 

CALL  TEXT(2, ) 

i 

WRITE  TEXT  STRING 

0533 

END  IF 

i 

END  IF  BLOCK 

0534 

CALL  MOVE( 360,397) 

1 

MOVE  TO  THESE  COORDS 

0535 

CALL  TEXT ( 4 , ' LAT ; ' ) 

i 

WRITE  TEXT  STRING 

0536 

CALL  MOVE( 400 , 397 ) 

i 

MOVE  TO  THESE  COORDS 

0537 

CALL  INUMBR (LAT(l) ,2) 

i 

WRITE  NUMBER 

0538 

CALL  MOVE( 424,397) 

i 

MOVE  TO  THESE  COORDS 

0539 

CALL  INUMBR ( LAT ( 2 ) , 2 ) 

i 

WRITE  NUMBER 

0540 

CALL  MOVE( 448 , 397 ) 

i 

MOVE  TO  THESE  COORDS 

>1 

CALL  INUMBR ( LAT ( 3 ) ,  2 ) 

i 

WRITE  NUMBER 

0542 

CALL  MOVE( 464 , 397 ) 

i 

MOVE  TO  THESE  COORDS 

0543 

CALL  TEXT( 1 ,  '  - '  ) 

i 

WRITE  TEXT  STRING 

0544 

CALL  MOVE( 472,397) 

i 

MOVE  TO  THESE  COORDS 

0545 

CALL  TEXT ( 1 , LAT ( 4 ) ) 

i 

WRITE  TEXT  STRING 

0546 

CALL  MOVE (504, 397) 

i 

MOVE  TO  THESE  COORDS 

0547 

CALL  TEXT( 5 , ' LONG ; ' ) 

i 

WRITE  TEXT  STRING 

0543 

CALL  MOVE( 552,397) 

i 

MOVE  TO  THESE  COORDS 

0549 

CALL  INUMBR ( LONG( 1) ,3) 

i 

WRITE  NUMBER 

0550 

CALL  MOVE( 584,397) 

i 

MOVE  TO  THESE  COORDS 

0551 

CALL  INUMBR ( LONG ( 2 ) , 2 ) 

i 

WRITE  NUMBER 

0552 

CALL  MOVE( 608 , 397 ) 

i 

MOVE  TO  THESE  COORDS 

0553 

CALL  INUMBR ( LONG ( 3 ) , 2 ) 

i 

WRITE  NUMBER 

0554 

CALL  MOVE( 624 , 397 ) 

i 

MOVE  TO  THESE  COORDS 

0555 

CALL  TEXT(1,'-' ) 

i 

WRITE  TEXT  STRING 

0556 

CALL  MOVE( 632,397) 

i 

MOVE  TO  THESE  COORDS 

0557 

CALL  TEXT ( 1 , LONG ( 4 ) ) 

1 

WRITE  TEXT  STRING 

0558 

0559  !-- 

— 

- LABEL  X  AXIS  FOR  BOTH  GRAPHS 

0560 

CALL  MOVE( 88,371) 

i 

MOVE  TO  THESE  COORDS 

0561 

CALL  TEXT ( 18, 'SOUND  SPEED 

(FT/S) ' ) !  WRITE  TEXT  STRING 

0562 

CALL  MOVE( 456,371) 

i 

MOVE  TO  THESE  COORDS 

0563 

CALL  TEXT( 18, 'SOUND  SPEED 

(FT/S) ' 

)  !  WRITE  TEXT  STRING 

0564 

0565  !-- 

- LABEL  Y  AXIS  FOR  BOTH  GRAPHS 

0566 

DO  359  J=0 , 376 , 376 

i 

DO  AT  0  AND  AT  376 

0*67 

IYF0S=245 

i 

SET  Y  COORDINATE 

|a 

DO  358  1=1,8 

i 

DO  EIGHT  TIMES 

0569 

CALL  MOVE( J , IYPOS ) 

i 

MOVE  TO  THESE  COORDS 

0570 

CALL  TEXT( 1 ,NL( I ) ) 

i 

WRITE  TEXT  STRING 

c-H*t  o 
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Vl 

0572 

0573 

0574 

0575 

0576 

0577 

0578 

0579 

0580 

0581 

0582 

0583 

0584 

0585 

0586 

0587 

0583 

0589 

0590 

0591 

0592 

0593 

0594 

0595 

0596 


0599 

0600 

0601 

0602 

0603 

0604 

0605 

0606 

0607 

0608 

0609 

0610 

0611 

0612 

0613 

0614 

0615 

0616 

0617 

0618 

0619 

0620 

0621 

0622 

0623 

0^24 

£5 

0626 

0627 


I YP0S=IYF0S-14 

358  CONTINUE 

359  CONTINUE 


IUD= ( ISVF-1 ) *10+1 
IF( ISVF.EQ . 5 )  IUD=21 
IDF  = IUD+9 
IYP0S=217 
DO  380  I=IUD , IDF 

CALL  MOVE( 608 , IYPOS) 
CALL  TEXT ( 1 , JSPDAT ( I ) ) 
IYP0S=IYP0S-14 
380  CONTINUE 

CALL  MOVE( 351 , 7 ) 

CALL  LNTYPE ( 3 ) 

CALL  DRAW( 431,7) 

CALL  LNTYPE(l) 

CALL  DRAW( 431,49) 

DO  390  NNN=7 ,49,14 
CALL  MOVE{ 431 ,NNN ) 
CALL  DRAW( 435 ,NNN ) 

390  CONTINUE 


!  RESET  Y  COORDINATE 
!  END  DO  LOOP 
!  END  DO  LOOP 

INSET  XBT  IN  SHALLOW  PROFILE 
!  POINTER  FOR  JSPDAT  ARRAY 
'  'KEYPUNCHED'  FLAG 
!  END  POINTER 
i  SET  Y  COORDINATE 
l  FOR  PART  OF  JSPDAT  ARRAY 
!  MOVE  TO  THESE  COORDS 
!  WRITE  TEXT  STRING 
I  RESET  Y  COORDINATE 
I  END  DO  LOOP 
!  MOVE  TO  THESE  COORDS 

i  TYPE  OF  LINE  _ 

!  DRAW  TO  THESE  COORDS 

!  TYPE  OF  LINE  _ 

!  DRAW  TO  THESE  COORDS 
i  DO  AT  7,21,35,49 
I  MOVE  TO  THESE  COORDS 
!  DRAW  TO  THESE  COORDS 
!  END  DO  LOOP 


BOTTOM  DEPTH 


CALL  MOVE( 72,35) 

CALL  TEXT(30, 'TRUE 
CALL  MOVE( 72,21) 

CALL  TEXT( 24, 'TRUE  WIND  SPEED 
CALL  MOVE( 120 , 7 ) 

CALL  TEXT( 29 , ' ****CANDIDATE 
CALL  MOVE( 440 ,49 ) 

CALL  TEXT (20, 'LAYER  DEPTH 
CALL  M0VE( 440 ,35 ) 

CALL  TEXT (12, 'SOUND  CHNL . - ' ) 
CALL  MOVE( 440 ,21 ) 

CALL  TEXT( 12 , ' CNVRG 
CALL  MOVE( 440 , 7 ) 

CALL  TEXT( 22 , ' BTTM. 

CALL  MOVE (536, 35) 

IF ( SCHNLD . LE . SCHMXD ) 

CALL  TEXT( 13 , ' AXIS 
CALL  MOVE( 608 , 35 ) 

IDEPSC = I IFIX ( SCHNLD ) 

CALL  INUMBR( IDEPSC, 3) 

ELSE 

CALL  TEXT ( 10 , ' NOT  USABLE') 
END  IF 

CALL  MOVE( 536,21) 

CALL  TEXT( 13, 'RANGE 
CALL  MOVE( 584,21) 
IRCZ=IIFIX(RCZ ) 

CALL  INUMBR ( IRCZ , 2 ) 

JBTMDP = I IFIX ( BDF ) 

CALL  MOVE( 216,35) 

CALL  INUMBR (JBTMDP, 4) 
JWIND=IIFIX(WS) 


THE  BOTTOM  LINES  OF  TEXT 
TO  THESE  COORDS 

WRITE  TEXT 
COORDS 
WRITE  TEXT 
COORDS 
WRITE  TEXT 
COORDS 


,  ZONE-') 

BOUNCE-MGS 

THEN 
DEF  = 


KYDS' ) 


PUT  ON 
!  MOVE 

FATHOMS ' ) ! 
i  MOVE  TO  THESE 
KNOTS ' )  l 

!  MOVE  TO  THESE 
ACOUSTIC  PATHS > ' )  ! 

!  MOVE  TO  THESE 
FT' )  l  WRITE  TEXT  STRING 
!  MOVE  TO  THESE  COORDS 
l  WRITE  TEXT  STRING 
l  MOVE  TO  THESE  COORDS 
1  WRITE  TEXT  STRING 
•  MOVE  TO  THESE  COORDS 
PROV. ' ) !  WRITE  TEXT  STRING 
MOVE  TO  THESE  COORDS 
SOUND  CHANNEL  DEPTH 
) !  WRITE  TEXT  STRING 
MOVE  TO  THESE  COORDS 
SOUND  CHANNEL  DEPTH 
WRITE  NUMBER 
SOUND  CHANNEL  DEPTH > MAX 
WRITE  TEXT  STRING 
END  IF  BLOCK 
MOVE  TO  THESE  COORDS 
WRITE  TEXT  STRING 
MOVE  TO  THESE  COORDS 
RANGE  OF  CONVERG.  ZONE 
WRITE  NUMBER 
BOTTOM  DEPTH  IN  FATHOMS 
MOVE  TO  THESE  COORDS 
WRITE  NUMBER 
WIND  SPEED 


c-W  l 
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0629 

0630 

0631 

0632 

0633 

0634 

0635 

0636 

0637 

0638 

0639 

0640 

0641 

0642 

0643 

0644 

0645 

0646 

0647 

0648 

0649 

0650 

0651 

0652 

0653 

0654 

*5 

0656 

0657 
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CALL  M0VE< 200,21) 
CALL  INUMBR ( JWIND , 2 ) 
LAYER  = I IFIX ( EL ) 

CALL  M0VE( 528,49) 
CALL  INUMBR (LAYER, 5) 
CALL  M0VE( 624,7) 
CALL  INUMBR ( MGS, 1) 
CALL  MOVE (0,0) 


WRTTE( 5 , 800 ) 

READ( 5,805)  ICOPY 
IF ( ICOPY . EQ . 0 )  GOTO  900 
DO  900  I  =  1, ICOPY 
WRITE( 5 ,850 ) 

900  CONTINUE 

CALL  UNCLIP 
CALL  ICLR 
999  RETURN 


!  MOVE  TO  THESE  COORDS 
l  WRITE  NUMBER 

l  LAYER  DEPTH 

!  MOVE  TO  THESE  COORDS 
!  WRITE  NUMBER 
!  MOVE  TO  THESE  COORDS 
!  WRITE  NUMBER 
!  DUMMY  CALL  TO  DELAY  EXIT 

HARDCOPY  OPTION - 

!  PROMPT  FOR  HOW  MANY  COPIES 
1  NUMBER  OF  COPIES  WANTED 
i  NONE  WANTED,  SKIP  NEXT 

!  DO  FO  NUMBER  OF  COPIES 

!  WRITE  WHAT  IS  ON  SCREEN 
l  1  END  DO  LOOP 
!  NO  CLIPPING 
•  CLEAR  SCREEN 
!  RETURN  TO  CALLING  ROUTINE 


- FORMAT  STATEMENTS - 

106  FORMAT (1H$, 'DO  YOU  WANT  THE  PROFILE  DRAWN  ON  YOUR  TEK-4025  (YES 
1  OR  NO)  ' ,T60 , '  ' ) 

191  FORMAT ( '  ! BEL ','***  RAW  DATA  IN  SHALLOW  SVP  WITH  X''S  *** ' ,/) 

800  FORMAT (1H$, 'HOW  MANY  HARD  COPIES  WOULD  YOU  LIKE?  CO, 1,2, ETC. 3  ') 
805  FORMAT ( 12 ) 

850  FORMAT  (  '  !HCO  S') 

950  FORMAT (A1 ) 

END 


0001 
0002 
0003 
0004 
0005 
0006 
0007 
0008 
0009 
0010 
0011 
0012 
0013 
0014 
0015 
0016 
0017 
0018 
0019 
0020 
0021 
0022 
0023 
0024 
0025 
0026 
0027 
0028 
0029 
J  0  3  0 
0031 
0032 
0033 
0034 
0035 
0036 
0037 
0038 
0039 
0040 
0041 
0042 
0043 
0044 
0045 
0046 
0047 
0048 
0049 
0050 
0051 
0052 
0053 
0054 
0055 
3*056 
y057 
0058 
0059 


SUBROUTINE  SVPRO( MONTH) 


1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 
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PROLOGUE : 

MODULE  NAME:  SVPRO 

AUTHOR:  S.  KO,  S.  LAFLEUR  &  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  1974,  1982  (REDESIGN)  &  12/83  (FORTRAN  77) 

FUNCTION:  SUBROUTINE  SVPRO  WILL  READ  SOUND  SPEED  PROFILE  ACCORDING 
TO  SOUND  SPEED  INDEX  OF  THE  OCEAN  AREA.  OTHER  PARAMETERS 
WILL  BE  WILL  ALSO  BE  DETERMINED  FROM  THE  DATA  BASE. 

INPUTS:  PARAMETERS  PASSED  IN.  VARIABLES  IN  COMMONS. 

OUTPUTS:  MODIFIED  PARAMETERS  PASSED  OUT. 

MODULES  CALLED:  NONE 
CALLED  BY:  ENVIRN , FORCST 


INCLUDE  ' ENVN. INC ' 


VARBL 

SIZE 

- ENVN - 

PURPOSE 

TYPE 

BIO 

(2) 

BIOLOGICAL  BACK  SCATTERING 

REAL *4 

DLYR 

LAYER  DEPTH 

REAL *4 

MGS 

MGS  PROVINCE 

INTEGER* 2 

RANGE 

-57.  &  -47. 


REAL *4  BIO, DLYR 

INTEGER* 2  MGS 
DATA  BIO/-57. ,-47./ 


COMMON  /ENVN/  BIO( 2 ) , DLYR, MGS 


- END  envn 

INCLUDE  ' GRF . INC ' 


GRF 


!  VARBL 

SIZE 

PURPOSE 

TYPE 

RANGE 

!  DBT 

(25) 

DEPTH  OF  DEPTH/VEL  PAIR 

REAL *4 

!  IANS 

PREDICTION  TYPE 

INTEGER*2 

-2  TO  +2 

!  ILYR 
!  INBT 
!  ISVP 

INDEX  FOR  LAYER  DEPTH 

OPERATOR  ENTERED  #  OF  BT  POINTS 
LATEST  OR  HISTORICAL  BT  FLAG 

INTEGER* 2 
INTEGER*2 
INTEGER*2 

1  OR  2 

!  12000 
!  VBT 

(25) 

SVP  INDEX  FOR  2000  FT  DEPTH 
VELOCITY  FOR  DEPTH  PAIR  REAL *4 

INTEGER *2 
REAL *4 

REAL *4  DBT , VBT 

INTEGER* 2  IANS, ILYR, INBT, ISVP, 12000 

COMMON  /GRF/  I ANS , ISVP , I LYR , 1 2000 , INBT , DBT ( 25 ) , VBT ( 25 ) 


END  GRF 


INCLUDE 

'LOC. INC' 

—  r nr  — - 

VARBL 

SIZE 

PURPOSE 

TYPE  RANGE 

INDX 

LAT 

(4) 

SSP  INDEX 
LATITUDE 

INTEGER* 2 
INTEGER* 2 

LONG 

(4) 

LONGITUDE 

INTEGER* 2 

NMAREA 

.  (20) 

AREA  OCEAN 

NAME 

BYTE 

NOC 

NUMBER  OF 

OCEAN 

INTEGER*2 

RCZ 

RANGE  TO  CONVERG. 

ZONE  REAL *4 

REAL *4 

RCZ 

C-49.1 


0060  1  INTEGER* 2  INDX , LAT , LONG ,NOC 

0061  1  BYTE  NMAREA( 20 ) 

0062  1 

0063  1  COMMON  /LOC/  LAT ( 4 ) , LONG ( 4  )  , NOC , I NDX , RCZ , NMAREA 

0064  1 

0065  1  ! - END  LOC - 

0066  INCLUDE  'SVP.INC' 

0067  1  ! - SVP - 

0068  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0069  1  ! -  -  -  - 

0070  1  !  BDF  BOTTOM  DEPTH  IN  FATHOMS  REAL* 4 

0071  1  !  BIOP  BIOLOGICAL  BACK  SCATTERING  COEF  REAL *4 

0072  1  !  BTDATE  (9)  DATE  OF  LAST  BT  INPUT  BYTE 

0073  1  !  BTTIME  (8)  TIME  OF  LAST  BT  INPUT  BYTE 

0074  1  !  C  (50)  VELOCITY  (PAIRED  WITH  Z  FOR  SVP)  REAL *4 

0075  1  !  CC  (50)  VELOCITY  (PAIRED  WITH  ZZ  FOR  SVP)REAL*4 

0076  1  !  CS  SOUND  VELOCITY  AT  SURFACE  REAL *4 

0077  1  !  DEG  TEMPERATURE  (DEG)  REAL *4  57.2957795 

0078  1  !  EL  LAYER  DEPTH  DATA 

0079  1  !  F  FREQUENCY  REAL *4 

0080  1  !  GRDS  GRIDS  _  REAL *4  0.0164 

0081  1  !  ITO  MINIMAL  2-WAY  TRAVEL  TIME  INTEGER* 2 

0082  1  !  MGSOP  MGS  PROVINCE  NUMBER  I NT EGER *2 

0083  1  !  N  #  OF  DEPTH/ VELOCITY  PAIRS  INTEGER* 2 

0084  1  !  NN  #  OF  DEPTH/VELOCITY  PAIRS  INTEGER* 2 

0085  1  !  PI  MATHEMATICAL  CONSTANT  PI  REAL *4  3.1415927 

0086  1  !  SNDATE  (9)  DATE  SYS  PARMS  LAST  UPDATED  BYTE 

0087  1  !  SNTIME  (8)  TIME  SYS  PARMS  LAST  UPDTAED  BYTE 

1088  1  !  SYDATE  (9)  CURRENT  DATE  READ  FROM  SYSTEM  BYTE 

0089  1  !  SYTIME  (8)  CURRENT  TIME  READ  FROM  SYSTEM  BYTE 

0090  1  !  TMP  TEMPERATURE  •  REAL *4 

0091  1  !  UMKZ  BOTTOM  BACK  SCATTERING  COEF.  REAL *4  -28.0 

0092  1  !  WS  WIND  SPEED  REAL*4 

0093  1  !  Z  (50)  DEPTH  OF  POINT  OF  SOUND  SPEED  REAL *4 

0094  1  !  ZZ  (50)  DEPTH  OF  POINT  OF  SOUND  SPEED  REAL *4 

0095  1 

0096  1  INTEGER* 2  ITO , MGSOP , N , NN 

0097  1  REAL *4  BDF , BIOP , C ( 50 ) , CC ( 50 ) , CS , DEG , EL , F , GRDS 

0098  1  REAL *4  PI , TMP , UMKZ , WS , Z ( 50 ) , ZZ ( 50 ) 

0099  1  BYTE  SYDATE( 9 ), SYTIME ( 8 ), BTDATE ( 9 ), BTTIME ( 8 ) 

0100  1  BYTE  SNDATE ( 9 ) , SNT IME ( 8 ) 

0101  1  DATA  PI, DEG, GRDS/3. 1415927, 57. 2957795, 0.0164/ 

0102  1  DATA  UMKZ/-28 . / 

0103  1 

0104  1  COMMON  /SVP/  F , N , Z , C , EL , MGSOP , BDF , WS , CS , TMP , SIOP , 

0105  1  1  UMKZ, PI, DEG, GRDS, ITO, ZZ,CC,NN, 

0106  1  2  SYDATE, SYTIME, BTDATE, BTTIME, SNDATE, SNT I ME 

0107  1  1 - SVP-END - 

0108  INCLUDE  'SVP1.INC' 

0109  1  ! - SVP1 - 

0110  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0111  1  !  - -  -  -  - 

0112  1  !  BUFFER  (224)  HISTORICAL  DATA  FILE  BUFFER  REAL *4 

0113  1  !  DS  (30)  HISTORICAL  DEPTH  REAL  *  4 

0114  1  !  J20  #  OF  DEEP  OCEAN  DEPTH/VEL  PAIRS  INTEGER* 2 

1115  1  !  NS  TOTAL  #  OF  PAIRS  IN  HISTORICAL  INTEGER *2 

<3116  1  !  NSN  MONTH  NUMBER  (1=JAN.,ETC)  INTEGER* 2  1  TO  12 

0117  1  !  SLNTY  SALINITY  REAL* 4 

0118  1  !  VS  (30)  HISTORICAL  VELOCITY  REAL *4 


C-V9.2. 


0119 
0120 
J 1 2 1 
0122 
0123 
0124 
0125 


<{U7 

yi48 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 

0161 

0162 

0163 

0164 

0165 

0166 

0167 

0168 

0169 

0170 

0171 

0172 

0173 

'1174 

/L75 

0176 

0177 


1 

1 

1 

1 

1 

1 


REAL* 4  BUFFER ,DS,SLNTY, VS 
INTEGER*2  J20,NSN,NS 

COMMON  /SVP1/  J20 , BUFFER ( 224 )  , NSN, SLNTY, DS ( 30 ) , VS ( 30 ) , NS 
- END  SVP1 - 


0126 

!  VARBL 

SIZE 

PURPOSE 

TYPE 

0127 

i - 

• 

— 

— 

0128 

!  I 

COUNTER 

INTEGER*2 

0129 

!  ISN 

SEASON  (INT  DIVISION) 

INTEGER* 2 

0130 

!  J 

COUNTER 

INTEGER* 2 

0131 

!  JDV 

(5) 

NUMBER  OF  DEPTH/VEL  PAIRS  PER  OCEAN 

INTEGER* 2 

0132 

!  K 

COUNTER 

INTEGER*2 

0133 

!  LBIO 

POINTER 

INTEGER*2 

0134 

!  LNDX 

(5) 

LOGICAL  RECORD  LENGTH  FOR  OCEAN(l-5) 

INTEGER*2 

0135 

!  LOC 

POINTER 

INTEGER*2 

0136 

!  LREC 

LOGICAL  RECORD  LENGTH  ARRAY 

INTEGER* 2 

0137 

!  L0 

POINTER 

INTEGER* 2 

0138 

!  M 

NUMBER  OF  RECORDS  IN  FILE  NOC 

INTEGER*2 

0139 

!  MM 

LENGTH^ OF  RECORD  (WORDS)  IN  NOC 

INTEGER*2 

0140 

I  MONTH 

NUMBER  OF  MONTH 

INTEGER*2 

0141 

!  NAME 

(12) 

NAMES  OF  OCEAN  AREA 

INTEGER* 2 

0142 

!  OCNAME 

(3,5) 

NAMES  OF  OCEAN  AREA 

INTEGER* 2 

0143 

!  RECLEN 

(5) 

RECORD  LENGTH 

INTEGER* 2 

0144 

0145 

!  RECNUM 

i 

• 

(5) 

NUMBER  OF  RECORDS  IN  FILE 

INTEGER *2 

0146 

j  ***  VARIABLES 

NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMONS  *** 

RANGE 


1  TO  12 


NOTE:  THESE  OCEANS  HAVE  20  DEPTH/VEL  PAIRS  AND  RECORD  LENGTH  224: 

NORTH  PACIFIC,  NORTH  ATLANTIC,  INDIAN,  NORWEGIAN. 

THE  MEDITERRANEAN  HAS  6  DEPTH/VEL  PAIRS  &  RECORD  LENGTH  196. 

INTEGER* 2  I , ISN, J , JDV , K , LB IO, LNDX , LOC , LREC , L0 , M , MM, MONTH , NAME 
INTEGER* 2  OCNAME , RECLEN , RECNUM 

DIMENSION  JDV ( 5 ) , LNDX ( 5 ) , RECNUM ( 5 ) , RECLEN ( 5 ) ,NAME(12) 
DIMENSION  OCNAME (3, 5) 

DATA  JDV/2*20 , 6 , 2*20/, LNDX/ 2 *2 24 ,220,2*224/, 

1  RECNUM/69 , 77,5,50,45/, RECLEN/2*448 , 440 , 2*448/ , 

2  NAME/’  V  ’,3*'  * , ’ .D* , 'AT' , ' ; 1 ' ,0/, 

3  OCNAME/ ' NP' , 'AC' , '  ' , ' NL ' , ' AN' , ' T ' , ' ME ' , ' D3 ' , ' 2 1 , ' IN ' , 

4  'DI ' , ' AN' , 'NR' , 'W' , '  '/ 


ISN= (MONTH+2 ) /3 
L0=169 

J20=JDV(NOC) 

IF(NOC.EQ. 5 .AND. INDX.LE. 39 ) 

J20=18 

LREC= LNDX ( NOC ) 

NAME ( 6 ) =OCNAME ( 1 , NOC ) 

NAME ( 7 ) =OCNAME { 2 , NOC ) 

NAME ( 8 ) =OCNAME ( 3 , NOC ) 

M= RECNUM ( NOC ) 

MM=RECLEN ( NOC ) 

CALL  ASSIGN (3, NAME) 

DEFINE  FILE  3  (M,MM,U, INDX) 

READ ( 3 ' I NDX )  ( BUFFER ( I ) , 1=1 , LREC ) 


SET  PARMS;  OPEN  SELECTED  OCEAN 
GET  SEASON  ( INT  DIVISION) 
LOCATION  FOR  POINTER 
SELECT  D , V  PAIRS 
OCEAN=5  &  INDEX<39 
SET  DEPTH/VEL  PAIR  POINTER 
LOGICAL  RECORD  LENGTH 
DATA  FILE  NAME  1ST  2  CHARS 
SECOND  2  CHARS 
THIRD  2  CHARS 
NUMBER  OF  RECORDS  IN  FILE 
LENGTH  OF  RECORD  (WORDS) 
ASSIGN  FILE  TO  UNIT  3 
FILE  PARAMETERS 
READ  BUFFER 


c-m.z 


0178  INDX=INDX-1  !  DECREASE  PROFILE  INDEX 

0179  CALL  CLOSE ( 3 )  !  CLOSE  FILE  3 

pi80 

0181  ! - SET  MISC  PARMS  FROM  HISTORICAL 

0182  LOC=LO+2* ( J20+1 )  !  FACTOR  FOR  POINTER 

0183  LBIO=LOC+2* ( ISN-1 )  !  POINTER 

0184  BIO( 1) =BUFFER( LB IO)  !  BIOLOGICAL  BACKSCATTERING 

0185  BIO ( 2 ) =BUFFER ( LB I O+l )  !  BIOLOGICAL  BACKSCATTERING 

0186  UMKZ=BUFFER ( LOC+8 )  !  BOTTOM  BACKSCATTERING 

0187  SLNTY=BUFFER ( LOC+9 )  !  SALINITY 

0188 

0189  ! - SET  NEAR  SURFACE  DATA (4  TO  7  DA 

0190  M=( MONTH- 1 ) *14+1  !  MONTH  POINTER 

0191  DO  220  J=1 , 7  !  DO  SEVEN  TIMES 

0192  DS ( J ) =BUFFER(M)  !  SET  HISTORICAL  DEPTH 

0193  VS ( J ) =BUFFER(M+1 )  !  SET  HISTORICAL  VELOCITY 

0194  I F ( J . GT . 1 . AND . DS ( J ) . LE . 1 . )  GO  TO  222  !  IF  DEPTH  <  1.0 

0195  M=M+2  !  ADD  2  TO  POINTER 

0196  220  CONTINUE  !  END  DO  LOOP 

0197  J=8  !  SET  COUNTER  TO  EIGHT 

0198  222  NS=J20+J-1  !  DEEP  OCEAN  UPPER  LIMIT 

0199 

0200  ! - DEEP  OCEAN  STARTS  AT  ITEM  57  OF 

0201  M=L0  !  L0  POINTS  TO  57  OF  BUFFER 

0202  DO  225  K=J,NS  !  FOR  DEEP  OCEAN 

0203  DS (K) =BUFFER(M)  !  SET  HISTORICAL  DEPTH 

0204  VS ( K ) = BUFFER ( M+ 1 )  !  SET  HISTORICAL  VELOCITY 

0205  M=M+2  !  ADD  2  TO  COUNTER 

0206  225  CONTINUE  !  END  DO  LOOP 

)207  DO  230  1=1, NS  !  FOR  DEEP  OCEAN 

0208  I F ( VS ( I ) . EQ . 0 )  GOTO  235  !  HISTORICAL  VELOCITY  =  0 

0209  230  CONTINUE  !  END  DO  LOOP 

0210  GO  TO  999  !  RETURN  TO  CALLING  ROUTINE 

0211  235  NS= 1-1  !  RESET  UPPER  LIMIT 

0212  999  RETURN  !  RETURN  TO  CALLING  ROUTINE 

0213  -END  !  END  SUBROUTINE 


0001 

0002 

b003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 

0011 

0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 

0021 

0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 


SUBROUTINE  TEXT ( LEN , STRNG ) 

PROLOGUE : 

MODULE  NAME:  TEXT 

AUTHOR:  J.  CASCIO,  W.  WACHTER ( FORTRAN  77),  NUSC/NL,  CODE  3333 
DATE:  1981  &  9/84  (FORTRAN  77) 

FUNCTION:  WRITES  OUT  A  STRING  OF  UP  TO  80  CHARACTERS  TO  THE 

RIGHT  OF  THE  CURRENT  CURSOR  POSITION  WITH  THE  TERMINAL  FONT. 
INPUTS:  STRING  TO  BE  WRITTEN 
OUTPUTS:  WRITTEN  STRING 
MODULES  CALLED:  NONE 
CALLED  BY:  I NUMB R ,  SVPGRF 


VARBL 

SIZE  PURPOSE 

TYPE 

RANGE 

I 

COUNTER 

INTEGER* 2 

ILEN 

LENGTH  OF  TEXT 

STRING 

INTEGER *2 

0  TO  80 

STRNG 

TEXT  STRING  TO 

BE  WRITTEN 

BYTE 

BYTE  STRNG (80) 

INTEGER *2  I, LEN 

IF  (LEN.GT.80  .OR.  LEN.LT.0)  LEN=80  !  RESET  IF  INVALID  LENGTH 

TYPE  1 , ( STRNG ( I ) , I = 1 , LEN )  !  WRITE  STRING 

RETURN  !  RETURN  TO  CALLING  ROUTINE 

j - FORMAT  STATEMENT - 

1  FORMAT ( '  ! STR  " ' , <LEN>A1 ,  '  ’"  ) 

END 


c-sa.  i 


18-Dec-1984  13:08:19 
18-Dec-1984  13:08:17 


'"'Ol 
v.  62 
0003 
0004 
0005 
0006 
0007 
0008 
0009 
0010 
0011 
0012 
0013 
0014 
0015 
0016 
0017 
0018 
0019 
0020 
0021 
0022 
0023 
0024 
0025 
0026 
0027 
0r‘7j8 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 


SUBROUTINE  VELTMP ( DEPTH ,  SS , T1 , SLNTY ) 


I  PROLOGUE: 

1  MODULE  NAME:  VELTMP 

I  AUTHOR:  R.  FLIGHT ( VITRO )  &  W.  WACHTER,  CODE  3333,  NUSC/NLL 
!  DATE:  1979  &  12/83  (FORTRAN  77) 

!  FUNCTION:  SUBROUTINE  VELTMP  IS  USED  TO  OBTAIN  THE  EQUIVALENT 
1  TEMPERATURE  FOR  A  SPECIFIED  SOUND  SPEED  AT  A  GIVEN 

l  DEPTH  AND  SALINITY. 

I  INPUTS:  PARAMETERS  PASSED  IN. 

I  OUTPUTS:  PARAMETERS  PASSED  OUT. 

I  MODULES  CALLED:  LEROY 
1  CALLED  BY:  ENVIRN,FORCST, METRIC 


I  VARBL  SIZE  PURPOSE 

j -  - 

!  DEPTH  DEPTH 

!  NCK  COUNTER 

!  SLNTY  SALINITY 

!  SS  SOUND  SPEED 

i  T1  TEMPERATURE 

1  VI  VELOCITY 

i 

INTEGERS  NCK 

REAL* 4  DEPTH, SLNTY, SS,T1, VI 


TYPE 

REAL*4 
INTEGER*2 
REAL*4 
REAL*4 
REAL*4 
REAL* 4 


RANGE 


NCK=0 

Tl=50. 

10  NCK=NCK+1 

CALL  LERO Y( DEPTH, Tl, SLNTY, VI) 
V1=V1-SS 

IF ( ABS ( VI ) .GT. .01. AND. NCK. LE. 
T1=T1-(V1*. 16676) 

GO  TO  10 
ELSE 
RETURN 
END  IF 
END 


!  INITIALIZE  TEMP  TO  50  DEGREES 
!  INCREASE  COUNTER 
!  GET  SOUND  SPEED  FOR  TEMP 
!  SOUND  SPEED  DIFFERENCE 
50)  THEN  !  SS  DIFF  >  0.01 
!  3.29  M/SEC/DEGREE  OR 
!  .16676  IN  ENGLISH  UNITS 

l  SS  DIFF  <=  0.01 
l  RETURN  TO  CALLING  ROUTINE 
!  END  IF  BLOCK 
I  END  SUBROUTINE 


C  -57. 1 


17-Dec-1984  12s43s4] 
17-Dec-1984  12:43:4( 

0001  SUBROUTINE  XBT( INSSP,NBT,NHIST,NEWBT) 

0002 

p3  !  PROLOGUE: 

0004  !  MODULE  NAME:  XBT 

0005  i  AUTHOR:  R.  FLIGHT( VITRO )  &  W.  WACHTER,  CODE  3333,  NUSC/NLL 
0006  !  DATE:  1979  &  12/ S3  (FORTRAN  77) 

0007  1  FUNCTION:  SUBROUTINE  XBT  IS  THE  MAIN  ROUTINE  FOR  THE  XBT 


OOOB  ERROR  CORRECTING  PROCESS. 

0009  l  INPUTS:  PARAMETERS  PASSED  IN  AND  VARIABLES  IN  COMMONS. 

0010  !  OUTPUTS:  NEW  BT  FLAG  AND  HISTORICAL  DATA  FLAG. 

0011  !  MODULES  CALLED:  DUPDEP , DUFVEL , GLITCH, INSERT, LAYER, LEROY, 

0012  !  LYRMOD , SMOOTH , SVPRO , XBTCHK , XBTERR ,XBTGRF ,XBTMOD 

0013  !  CALLED  BY:  ENVIRN ,FORCST 

0014  1 

0015  INCLUDE  'DTV.INC' 

0016  1  I - DTV - 

0017  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0018  1  !  - -  -  -  - 

0019  1  !  D  (25)  DEPTH  REAL* 4 

0020  1  !  DD  (25)  DEPTH  REAL*4 

0021  1  !  NNBT  NUMBER  OF  BATHETHERMAL  INTEGER* 2 

0022  1  1  T  (25)  TEMPERATURE  REAL*4 

0023  1  i  TT  (25)  TEMPERATURE  REAL* 4 

0024  1  !  VEL  (25)  VELOCITY  REAL*4 

0025  1  1 

0026  1  INTEGER*2  NNBT 

0027  1  REAL* 4  D,DD,T,TT,VEL 

0028  1 

0029  1  COMMON  /DTV/  D( 25 ) ,T( 25 ) ,VEL( 25 ) ,DD( 25 ) ,TT( 25 ) ,NNBT 

]50  1  i - END  DTV - 

0031  INCLUDE  'ENVN.INC' 

0032  1  1 - ENVN - 

0033  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0034  1  1  - -  -  -  - 

0035  1  i  BIO  (2)  BIOLOGICAL  BACK  SCATTERING  REAL*4  -57.  &  -47. 

0036  1  !  DLYR  LAYER  DEPTH  REAL* 4 

0037  1  !  MGS  MGS  PROVINCE  INTEGER* 2 

0038  1 

0039  1  REAL* 4  BIO, DLYR 

0040  1  INTEGER*2  MGS 

0041  1  DATA  BIO/ -57. ,-47. / 

0042  1 

0043  1  COMMON  /ENVN/  BIO( 2) , DLYR, MGS 

0044  1 

0045  1  ! - END  ENVN - 

0046  INCLUDE  ' GRF . INC ' 

0047  1  ! - GRF - 

0048  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0049  1  !  - -  -  -  - 

0050  1  !  DBT  (25)  DEPTH  OF  DEPTH/ VEL  PAIR  REAL*4 

0051  1  !  IANS  PREDICTION  TYPE  INTEGER* 2  -2  TO  +2 

0052  11  ILYR  INDEX  FOR  LAYER  DEPTH  INTEGER*  2 

0053  1  1  INBT  OPERATOR  ENTERED  #  OF  BT  POINTS  INTEGER* 2 

0054  1  1  ISVP  LATEST  OR  HISTORICAL  BT  FLAG  INTEGER* 2  1  OR  2 

0055  1  !  12000  SVP  INDEX  FOR  2000  FT  DEPTH  INTEGER* 2 

0056  1  1  VBT  (25)  VELOCITY  FOR  DEPTH  PAIR  REAL* 4  REAL* 4 

>7  1 


C-SZA 


17-Dec-1984  12s43:41 
17-Dec-1984  12s43:4C 


XBT 


0058  1  REAL* 4  DBT,VBT 

0^59  1  IHTEGER*2  IANS , ILYR , INBT , ISVP , 12000 

10  1 

0061  1  COMMON  /GRF/  IANS , ISVP , ILYR , 12000 , INBT,DBT( 25 ) ,VBT( 25 ) 

0062  1 

0063  1  ! - END  GRF - 

0064  INCLUDE  'LOC.INC' 

0065  1  ! - LOC - 

0066  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0067  1  !  - -  -  -  - 

0068  1  !  INDX  SSP  INDEX  INTEGER* 2 

0069  1  !  LAT  (4)  LATITUDE  INTEGER* 2 

0070  1  l  LONG  (4)  LONGITUDE  INTEGER* 2 

0071  1  !  NMAREA  (20)  AREA  OCEAN  NAME  BYTE 

0072  11  NOC  NUMBER  OF  OCEAN  INTEGER* 2 

0073  1  1  RCZ  RANGE  TO  CONVERG.  ZONE  REAL*4 

0074  1 

0075  1  REAL*4  RCZ 

0076  1  INTEGER*2  INDX, LAT, LONG, NOC 

0077  1  BYTE  NMAREA ( 20 ) 

0078  1 

0079  1  COMMON  /LOC/  LAT ( 4 ) , LONG ( 4 ) , NOC , INDX , RCZ , NMAREA 

0080  1 

0081  1  1 - END  LOC - 

0082  INCLUDE  'SVP. INC' 


0083 

1 

— 

- svp - 

0084 

1 

i 

VARBL 

SIZE 

PURPOSE 

TYPE 

0085 

1 

i 

— 

— 

r~<36 

1 

! 

BDF 

BOTTOM  DEPTH  IN  FATHOMS 

REAL*4 

V  hi 

1 

i 

BIOP 

BIOLOGICAL  BACK  SCATTERING  COEF 

REAL* 4 

0088 

1 

i 

BTDATE 

(9) 

DATE  OF  LAST  BT  INPUT 

BYTE 

0089 

1 

i 

BTTIME 

(8) 

TIME  OF  LAST  BT  INPUT 

BYTE 

0090 

1 

i 

C 

(50) 

VELOCITY  (PAIRED  WITH  Z  FOR  SVP) 

REAL*4 

0091 

1 

i 

cc 

(50) 

VELOCITY  (PAIRED  WITH  ZZ  FOR  SVP)REAL*4 

0092 

1 

i 

cs 

SOUND  VELOCITY  AT  SURFACE 

REAL*4 

0093 

1 

i 

DEG 

TEMPERATURE  (DEG) 

REAL*4 

0094 

1 

i 

EL 

LAYER  DEPTH 

DATA 

0095 

1 

i 

F 

FREQUENCY 

REAL *4 

0096 

1 

1 

GRDS 

GRIDS 

REAL*4 

0097 

1 

l 

ITO 

MINIMAL  2 -WAY  TRAVEL  TIME 

INTEGER* 2 

0098 

1 

i 

MGS  OP 

MGS  PROVINCE  NUMBER 

INTEGER* 2 

0099 

1 

i 

N 

#  OF  DEPTH /VELOCITY  PAIRS 

INTEGER* 2 

0100 

1 

l 

NN 

#  OF  DEPTH /VELOCITY  PAIRS 

INTEGER* 2 

0101 

1 

i 

PI 

MATHEMATICAL  CONSTANT  PI 

REAL*4 

0102 

1 

l 

SNDATE 

(9) 

DATE  SYS  PARMS  LAST  UPDATED 

BYTE 

0103 

1 

i 

SNTIME 

(8) 

TIME  SYS  PARMS  LAST  UPDTAED 

BYTE 

0104 

1 

l 

SYDATE 

(9) 

CURRENT  DATE  READ  FROM  SYSTEM 

BYTE 

0105 

1 

l 

SYTIME 

(8) 

CURRENT  TIME  READ  FROM  SYSTEM 

BYTE 

0106 

1 

1 

TMP 

TEMPERATURE 

REAL*4 

0107 

1 

i 

UMKZ 

BOTTOM  BACK  SCATTERING  COEF. 

REAL*4 

0108 

1 

[ 

WS 

WIND  SPEED 

REAL* 4 

0109 

1 

i 

Z 

(50) 

DEPTH  OF  POINT  OF  SOUND  SPEED 

REAL*4 

0110 

1 

l 

ZZ 

(50) 

DEPTH  OF  POINT  OF  SOUND  SPEED 

REAL* 4 

0111 

1 

0112 

1 

INTEGER* 2  ITO , MGSOP , N , NN 

0n\3 

1 

REAL* 4 

BDF, BIOP, C( 50) ,CC( 50) ,CS , DEG, EL, F, GRDS 

l  /4 

1 

REAL*4 

PI , TMP, UMKZ, WS ,Z( 50) ,ZZ(50) 

RANGE 


57.2957795 


0.0164 


3.1415927 


-28.0 


XBT 
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0115 

T 

0118 

0119 

0120 

017.1 

0122 

0123 

0124 

0125 

0126 

0127 

0123 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0133 

0139 

0140 

0141 

0142 

0143 

y 

0145 
0146 
0147 
0148 
0149 
0150 
0151 
0152 
0153 
0154 
0155 
0156 
0157 
0153 
0159 
0160 
0161 
0162 
0163 
0164 
0165 
0166 
0167 
0168 
0169 
0170 
'  )1 


1  BYTE  S YDATE ( 9 ) , S YTIME ( 8 ) , BTDATE (  9 )  , BTTIME ( 8 ) 

1  BYTE  SNDATE ( 9 ) , SNTIME ( 8 ) 

1  DATA  FI, DEG, GRDS/3. 1415927, 57. 2957795, 0.0164/ 

1  DATA  UMKZ/-28 . / 

1 

1  COMMON  /SVF/  F,N,Z,C,EL,MGSOP,BDF,WS,CS,TMP,BIOF, 

1  1  UMKZ ,PI ,DEG ,GRDS ,ITQ,ZZ,CC,NN, 

1  2  S YDATE, S YTIME, BTDATE, BTTIME, SNDATE, SNTIME 

1  i - S  VP -END - 

INCLUDE  ' SVP1 . INC ' 

1  i - SVP1 - 

1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

1  i -  -  -  - 

1  1  BUFFER  (224)  HISTORICAL  DATA  FILE  BUFFER  REAL*4 

1  !  DS  (30)  HISTORICAL  DEPTH  REAL*4 

1  i  J20  #  OF  DEEP  OCEAN  DEPTH/VEL  PAIRS  INTEGER A 2 

1  !  NS  TOTAL  #  OF  PAIRS  IN  HISTORICAL  INTEGERS 2 

1  !  NSN  MONTH  NUMBER  (1=JAN.,ETC)  INTEGERS 2  1  TO  12 

1  !  SLNTY  SALINITY  REAL*4 

1  !  VS  (30)  HISTORICAL  VELOCITY  REAL*4 

1 

1  REAL* 4  BUFFER, DS, SLNTY, VS 

1  INTEGER* 2  J20,NSN,NS 

1 

1  COMMON  /SVF1/  J20,BUFFER(224) , NSN, SLNTY, DS(30) ,VS(30) , NS 

1  i - END  SVP1 - 

i 

!  VARBL  SIZE  PURPOSE  TYPE  RANGE 

!  BAD  #  OF  POINTS  NOT  IN  ACCEPTABLE  RANGE  REAL* 4 

l  CNT  TOTAL  #  OF  POINTS  LESS  THAN  1500'  REAL* 4 

l  ERRBT  ERROR  FLAG  FOR  BT  REAL* 4 

(  HLYR  HISTORICAL  LAYER  DEPTH  REAL* 4 

>  I  COUNTER  INTEGER* 2 

!  IMNTH  NUMBER  OF  MONTH  INTEGER* 2  1  TO  12 

l  INSSP  SOUND  SPEED  PROFILE  INPUTTED  INTEGER* 2 

!  J  COUNTER  INTEGER* 2 

!  MONTH  NUMBER  OF  MONTH  INTEGER*  2  1  TO  12 

!  NBT  NUMBER  OF  BT  POINTS  INTEGER* 2 

1  NDLYR  BT  LAYER'S  POSITION  IN  ARRAY  INTEGER* 2 

I  NEWBT  NEW  BT  FLAG  INTEGER*  2 

!  NHIST  HISTORICAL  DATA  FLAG  INTEGER* 2 

i  NHLYR  HISTORICAL  LAYER'S  POSITION  IN  ARRAY  INTEGER *2 

i  NI  NUMBER  OF  HISTORIC  DATA  POINTS  -  1  INTEGER* 2 

!  N2  MERGE  ROUTINE  FLAG  INTEGER*2 

i 


!  ***  VARIABLES  NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMONS  *** 
INTEGER*2  I , IMNTH , INSSP ,J 

INTEGER*  2  MONTH , NBT , NDLYR , NEWBT , NHIST , NHLYR , NI , N2 


REAL* 4  BAD, CNT 

REAL *4  ERRBT, HLYR,VEL1 

i - PRELIMINARIES - 

5  NHIST=0  l  HISTORCAL  DATA  FLAG 

NEWBT =0  !  NEW  BT  FLAG 

N2=l  !  MERGE  ROUTINE  FLAG 


c  - 


XBT 


0172 

31 

0175 
0176 
0177 
0178 
0179 
0180 
0181 
0182 
0183 
0184 
0185 
0186 
0187 
0188 
0189 
0190 
0191 
0192 
0193 
0194 
0195 
0196 
0197 
0198 
0199 
)0 
>1 
0202 
0203 
0204 
0205 
0206 
0207 
0208 
0209 
0210 
0211 
0212 
0213 
0214 
0215 
0216 
0217 
0213 
0219 
0220 
0221 
0222 
0223 
0224 
0225 
0226 

31 


J! 


20 

40 


50 


GO  TO  40 
CNT=CNT+1. 


CNT=0 .  ! 

IMNTH=0  ! 

INBT=NBT  ! 

ERRBT=0.  ! 

BAD=0 .  1 

MONTH  =  NSN  ! 

DO  20  1=1, NBT  ! 

IF ( D( I ) .GT.2500. ) 

IF(D(I) .LT.1500.  ) 

CALL  LEROY(Dd)  ,T(I)  ,SLNTY,VBT(I)  ) 
DBT ( I ) =D ( I ) 

VEL ( I ) =VBT ( I ) 

CONTINUE 

CALL  XBTGRF( MONTH) 

CALL  SVFRO( MONTH) 

CALL  LAYER ( NS , DS , VS , HL YR ) 

CALL  INSERT ( NS, DS, VS, HLYR, NHL YR) 

CALL  LAYER ( NBT, D, VEL, DLYR) 

CALL  INSERT(NBT,D, VEL, DLYR, NDLYR) 

DO  50  J = 1 , NBT 

IF(T( J) .LT.27. .OR.T( J) .GT.95. ) 
IF(D(J) .LT.1500. )  BAD=BAD+1. 

IF ( BAD . GT . ( CNT* . 5 ) )  THEN  ! 

ERRBT- 1.  ! 


THEN! 

i 
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COUNT  OF  #  OF  BT  POINTS 
MONTH  NUMBER 

#  OF  BT  POINTS 
BT  ERROR  FLAG 

#  OF  INVALID  POINTS 
MONTH  NUMBER 

DO  FOR  NUMBER  OF  BT 
>2500  FEET,  SKIP  NEXT 
!  CNT=  #  OF  BT  PTS  <1500 
CONVERT  FROM  DEPTH /TEMP 
STORE  DEPTH/VEL  PAIRS 
STORE  DEPTH/VEL  PAIRS 
END  DO  LOOP 
GRAPH  XBT 
GET  HIST  DATA 
GET  HIST  LAYER  DEPTH 
HIST  LAYER'S  POSITION 
GET  BT  LAYER  DEPTH 
GET  BT  LAYER'S  POSITION 
DO  FOR  #  OF  BT  POINTS 
OUTSIDE  TEMP  RANGE 
INVALID  IF  <  1500' 

>  HALF  ARE  INVALID, 

SET  ERROR  FLAG 


CALL  XBTERR ( INS SP , NBT , ERRBT , NHI ST , NEWBT , NDLYR ) 


GO  TO  999  ! 

END  IF  ! 

END  IF  ! 

CONTINUE  ! 

CALL  DUPDEP ( NBT , D , VEL )  ! 

CALL  DUFVEL ( NBT , D , VEL )  ! 

NI=NS-1  ! 

CALL  XBTCHK ( NBT , CNT , BAD , NI )  ! 

IF ( BAD . GT . CNT* . 5 )  THEN  ! 

ERRBT =2 .  ! 

CALL  XBTERRdNSSP, NBT, ERRBT, NHIST, NEWBT, NDLYR)  ! 
IF ( NEWBT . EQ . 2 )  THEN  !  NEW  SSP  AREA  CHOSEN 


!  CORRECT  BT 
ROUTINE 


BACK  TO  CALLING 
END  IF  BLOCK 
END  IF  BLOCK 
END  DO  LOOP 

RID  DOUBLE  CONSEC  DEPS 
RID  DOUBLE  CONSEC  VELS 
#  OF  HIST  DATA  POINTS- 1 
CHECK  BT  DATA 
MORE  THAN  HALF  ARE  BAD 
SET  BT  ERROR  FLAG 

CORRECT 


CALL  SVPRO( MONTH) 
GOTO  5 
END  IF 
GO  TO  999 
END  IF 


!  GET  HIST  DATA 
!  START  AGAIN 
!  END  IF  BLOCK 
!  BACK  TO  CALLING  ROUTINE 
!  END  IF  BLOCK 


i - MODIFY  LAYER  DEPTH  IF  REQUIRED 

CALL  LYRMOD( NBT, DLYR, NDLYR, HLYR)  !  FORCE  BT  LAYER  DEPTH 

i - IF  XBT  POINTS  ARE  OUTSIDE  TOLERANCE  ENVELOPE,  MOVE  THEM  TO  ENVELOPE 

CALL  XBTMODt NBT, NI,N2, NDLYR)  !  MODIFY  XBT  IF  REQUIRED 

DLYR=D( NDLYR)  !  LAYER  DEPTH 

i - REMOVE  GLITCHES  BELOW  LAYER 

IF(NBT.GE.NDLYR+3 )  CALL  GLITCH (NBT, NDLYR) 

CALL  DUPDEP ( NBT, D, VEL)  !  RID  DOUBLE  CONSEC  DEPS 

CALL  DUFVEL(NBT,D,VEL)  !  RID  DOUBLE  CONSEC  VELS 

CALL  LAYER ( NBT , D , VEL , DL YR )  !  GET  BT  LAYER  DEPTH 

CALL  INSERT ( NBT, D, VEL, DLYR, NDLYR)  !  GET  LAYER'S  POSITION 


XBT 
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0229 

i - 

- SMOOTH  XBT  DATA-  — 

0230 

IF ( BAD . NE . 0 . . AND . NBT . GE . 3 )  CALL 

SMOOTH ( NBT , NDLYR ) 

PI 

N2  =  0 

!  INITIALIZE  FLAG 

0232 

CALL  XBTM0D(NBT,NI,N2,NDLYR) 

!  CHECK  BT  VALUES 

VS  HIST 

0233 

999 

RETURN 

i  BACK  TO  CALLING 

ROUTINE 

0234 

END 

COMMAND  QUALIFIERS 

FORTRAN  / CHECK=ALL/ LIST/ SHOW=( INCLUDE, NOMAP)  CLAFLEUR3XBT.F77 

/ CHECK = ( BOUNDS , OVERFLOW , UNDERFLOW ) 

/ DEBUG = ( NOSYMBOLS ,TRACEBACK ) 

/ STANDARD = ( NOSYNTAX , NOSOURCE_FORM ) 

/ SHOW= ( NOPREPROCESSOR , INCLUDE , NOMAP ) 

/F77  / NOG_FLOATING  /I4  /OPTIMIZE  /WARNINGS  /NOD  LINES  /NOCROSS  REFERENCE  /l 


COMPILATION  STATISTICS 


Run  Time : 
Elapsed  Time: 
Page  Faults: 

.  Dynamic  Memory : 


2.57  seconds 
5.3B  seconds 
380 

147  pages 


C-SZ  S' 


SUBROUTINE  XBTCHK ( NBT , CNT , BAD , NI ) 


0001 
0002 

>003  !  PROLOGUE: 

0004  !  MODULE  NAME:  XBTCHK 

0005  !  AUTHOR:  S.  LAFLEUR,  W.  WACHTER  (FORTRAN  77) 

0006  !  DATE:  7/84  &  7/84  (FORTRAN  77) 

0007  !  FUNCTION:  SUBROUTINE  XBTCHK  DETERMINES  ACCEPTANCE  OR  REJECTION  OF 

0008  !  THE  BT  DATA.  IT  INTERPOLATES  THE  SOUND  SPEEDS  OF  THE  BT 

0009  !  AND  HISTORICAL  DATA  AT  EVERY  4  FEET  OF  DEPTH  FROM  SURFACE 

0010  !  TO  1500  FEET  OR  THE  LAST  DEPTH  ENTERED  FOR  THE  BT  IF  IT  IS 

0011  !  LESS  THAN  1500  FEET.  'CNT'  IS  INCREMENTED  AT  EVERY  ONE 

0012  !  OF  THESE  DEPTHS.  THE  TOLERANCE  ENVELOPE  IS  ALSO 

0013  !  CALCULATED  AT  EVERY  ONE  OF  THESE  DEPTHS.  'BAD'  IS 

0014  !  INCREMENTED  EVERY  TIME  THE  BT  SOUND  SPEED  VALUE  LIES 

0015  !  OUTSIDE  THE  TOLERANCE  ENVELOPE  ABOUT  THE  HISTORICAL  SOUND 

0016  !  SPEED  AT  THE  CURRENT  DEPTH.  IF  MORE  THAN  HALF  OF 

0017  !  THE  'CNT'  DEPTHS  ARE  'BAD',  THE  BT  WILL  BE  REJECTED. 

0018  !  INPUTS:  PARAMETERS  PASSED  IN  &  VARIABLES  IN  COMMONS. 

0019  !  OUTPUTS:  MODIFY  SS  TO  STAY  WITHIN  TOLERANCE  ENVELOPE 

0020  !  MODULES  CALLED:  NONE 

0021  !  CALLED  BY:  XBT 

0022  ! 

0023  INCLUDE  'DTV.INC' 

0024  1  ! - DTV - 

0025  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0026  1  ! -  -  -  - 

0027  1  !  D  (25)  DEPTH  REAL *4 

0028  1  !  DD  (25)  DEPTH  REAL *4 

0029  1  !  NNBT  NUMBER  OF  BATHETHERMAL  INTEGER*2 

j030  1  !  T  (25)  TEMPERATURE  REAL *4 

0031  1  !  TT  (25)  TEMPERATURE  REALM 

0032  1  !  VEL  (25)  VELOCITY  REAL *4 

0033  1  ! 

0034  1  INTEGER*2  NNBT 

0035  1  REAL *4  D , DD, T , TT , VEL 

0036  1 

0037  1  COMMON  /DTV/  D ( 2 5 ) , T ( 2 5 ) , VEL ( 25 ) , DD( 2 5 ) , TT ( 2 5 ) , NNBT 

0038  1  ! - END  DTV - 

0039  INCLUDE  'SVPl.INC' 

0040  1  ! - SVP1 - 

0041  1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0042  1  !  - -  -  -  - 

0043  1  !  BUFFER  (224)  HISTORICAL  DATA  FILE  BUFFER  REAL  *  4 

0044  1  !  DS  (30)  HISTORICAL  DEPTH  REAL *4 

0045  1  !  J20  #  OF  DEEP  OCEAN  DEPTH/VEL  PAIRS  INTEGER*2 

0046  1  !  NS  TOTAL  #  OF  PAIRS  IN  HISTORICAL  INTEGER*2 

0047  1  !  NSN  MONTH  NUMBER  (1=JAN., ETC)  INTEGER*2  1  TO  12 

0048  1  !  SLNTY  SALINITY  REAL *4 

0049  1  !  VS  (30)  HISTORICAL  VELOCITY  REAL *4 

0050  1 

0051  1  REALM  BUFFER,  DS ,  SLNTY,  VS 

0052  1  INTEGER*2  J20,NSN,NS 

0053  1 

0054  1  COMMON  /SVP1/  J20,BUFFER( 224) ,NSN, SLNTY, DS ( 30) , VS (30) , NS 

0055  1  ! - END  SVP1 - 

0056  ! 

)057  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

0058  ! -  -  -  - 


0059 


BAD 


POINTS  OUTSIDE  TOLERENCE  ENVELOPE  REAL *4 


C-r  3.1 


0060  !  BTSPD  BT  SS  AT  CURRENT  DEPTH  REAL* 4 

0061  !  CNT  NUMBER  OF  POINTS  <=  1500  FEET  REAL *4 

p  0  6  2  !  DEP  DEPTH  REAL *4 

0063  !  HSPD  HISTORICAL  SS  AT  CURRENT  DEPTH  REAL  *  4 

0064  !  I DEP  DEPTH  INTEGER*2 

0065  !  K  LOOP  COUNTER  INTEGER* 2 

0066  !  NBT  NUMBER  OF  BT  POINTS  INTEGER* 2 

0067  !  NI  #  OF  HISTORICAL  POINTS  INTEGER* 2 

0068  !  XX  1/2  ENVELOPE  TOLERANCE  WIDTH  REAL* 4 

0069  !  AT  CURRENT  DEPTH 

0070  ! 

0071  !  ***  VARIABLES  NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMONS  *** 

0072 

0073  INTEGER* 2  IDEP , K, NBT , NI 

0074  REAL *4  BAD, BTSPD, CNT , DEP , HSPD, XX 

0075 

0076  ! - PRELIMINARIES - 

0077  CNT=0 .  !  INIT  #  OF  PTS  <=  1500' 

0078  BAD=0 .  !  INIT  #  OF  PTS  OUTSIDE  ENVELOPE 

0079  DO  100  IDEP=0 ,1500,4  !  TO  TO  1500'  BY  4 

0080  DEP=FLOAT( IDEP)  !  REAL  NUMBER  DEPTH 

0081  I F ( DEP . GT . D ( NBT ) )  GO  TO  999  !  TOO  DEEP,  RETURN  TO  CALLING  RO 

0082  IF( DEP . LE . 1500 . )  CNT=CNT+1.  !  DEPTH<=1500 ' ,  INCREASE  COUNT 

0083 

0084  ! - GET  BT  SS  AT  CURRENT  DEPTH - 

0085  DO  200  K=1 , NBT-1  !  DO  UNTIL  NEXT  TO  LAST  BT 

0086  IF(D(K) . LE , DEP . AND . D( K+l ) .GT.DEP)  GOTO  300  !  EXIT  LOOP 

0087  200  CONTINUE  !  END  DO  LOOP 

0088  300  BTSPD=VEL ( K ) + ( ( VEL ( K+l ) -VEL (K) )/(D(K+l)-D(K) ) )*( DEP-D ( K ) )  !  BT 

)089 

00  90  ! - GET  HISTORIC  SS  AT  CURRENT  DEPTH 

0091  DO  500  K=1;NI  !  COMPARE  DEPTHS  LOOP 

0092  IF(DS(K) .LE. DEP. AND. DS(K+1) .GT.DEP)  GOTO  600  !  EXIT  LOOP 

0093  500  CONTINUE  >  END  DO  LOOP 

0094  600  HSPD=VS ( K ) + ( ( VS ( K+ 1 ) -VS ( K ) ) / ( DS ( K+l ) -DS ( K ) ) ) * ( DEP-DS ( K )  )  !  HIS 

0095 

0096  ! - ENVELOPE  CHECK - 

0097  XX=15.-.006*DEP  !  1/2  ENVELOPE  TOLERENCE  WIDTH 

0098  IF(DEP.LE. 1500. AND. HSPD+XX.LT. BTSPD)  BAD=BAD+ 1 .  !  ENVELOPE  CHE 

0099  IF(DEP.LE. 1500. AND. HSPD-XX.GT. BTSPD)  BAD=BAD+1 .  !  ENVELOPE  CHE 

0100  100  CONTINUE  !  END  DO  LOOP 

0101  999  RETURN  !  RETURN  TO  CALLING  ROUTINE 

0102  END  !  END  SUBROUTINE 


C-T3r  ZL, 
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>1 

0u02 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 

0011 

0012 

0013 


0026 

0027 

0/,'\8 

0030 
0  031 
0032 
0033 


0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 


1 
1 
1 
1 
1 

1  ! 


SUBRGUT  INE  XBTERR  (  INSSP  ,  NBT  ,  ERRBT  ,  NH  1ST  , NENBT  ,  NDLYR) 

prologue: 

MODULE  NAME:  XBTERR 

AUTHOR:  R.  E‘L  IGHT  ( V ITRO )  %  W.  UACHTER,  CODE  3333,  NUSC/NLL 

DATE’  1979  %  12/83  (EORTRAN  77)  „„„ 

FUNCTION:  SUBROUTINE  XBTERR  PRODUCES  THE  ERROR  MESSAGES 

AND  ALLOWS  THE  OPERATOR  TO  SELECT  EITHER  NEW  BT , 
HISTORICAL  DATA,  OR  ADJUSTED  BT  DATA. 

INPUTS:  OPERATOR  SELECTION  FOR  BT  DATA.  PARAMETERS  PASSED  IN. 
OAR  I ABLES  IN  COMMONS. 

OUTPUTS:  CRT  PROMPTING  MESSAGES  TO  OPERATOR 
MODULES  CALLED:  ASIS,  INSERT,  METRIC 


0014 

i 

CALLS 

D  BY:  XBT 

0015 

i 

0016 

INCLUDE 

'  DTV. INC' 

0017 

1 

- LiTV - 

0018 

1 

j 

VA.RBL 

SIZE 

PURPOSE 

TYPE 

0019 

1 

j 

- - 

— 

0020 

1 

I 

D 

(25) 

DEPTH 

REALA4 

0021 

1 

j 

DD 

(25) 

DEPTH 

REAL.A4 

0022 

1 

} 

NNBT 

NUMBER  OF  BATHETHERMAL 

1NTEGERA2 

0023 

1 

i 

T 

<25  ) 

TEMPERATURE 

REALA4 

0024 

1 

! 

TT 

(25) 

TEMPERATURE 

REALA4 

0025 

1 

! 

VEL 

(25) 

VELOCITY 

REALA4 

RANGE 


INTEGERA2  NNBT 
REALA4  D  ,  D  D  ,  T  ,  T  T  ,  V  E  L 


COMMON  / D  T  0 / 


i 


0034 

1 

VARBL 

SIZE 

0035 

1 

— 

— 

0036 

1 

BIO 

(2) 

0037 

1 

DLYR 

0038 

1 

MGS 

0(25)  , T ( 25  )  , OEL ( 25 ) , DD ( 25 ) ,  TT ( 25 ) ,  NNBT 

- EN0  Dtv - 

INCLUDE  ' ENON . INC ' 

- ENyN - 

PURPOSE 


TYPE 


1 

1 

1 

1 

1 

1 

1 

1 


BIOLOGICAL  BACK  SCATTERING  REALA4 
LAYER  DEPTH  REALA4 

MGS  PROVINCE  INTEGERA2 


REAL A4  B  1 0 , D L Y R 
INTEGERA2  MGS 
DATA  B1G/-57. ,-47./ 

COMMON  /ENON/  BIO (2 ) , DLYP , MGS 


RANGE 

-57.  %.  -47, 


■END  ENVN- 


INCLUDE  ' GSF  .  INC ' 


0048 

1 

0  049 

1 

I 

VARBL 

S  IZE 

0050 

1 

j 

— 

0051 

1 

! 

DBT 

(25) 

0052 

1 

j 

IANS 

0053 

1 

l 

ILYR 

0054 

1 

| 

I  NBT 

0  \5 

1 

i 

ISVP 

0  76 

1 

! 

12000 

0  057 

1 

i 

VBT 

X  25 ) 

-GRE- 


PURPOSE 

DEPTH  OF  DEPTH/OEL  PAIR 
PREDICTION  TYPE 
INDEX  FOR  LAYER  DEPTH 
OPERATOR  ENTERED  *  OF  BT  POINTS 
LATEST  OR  HISTORICAL  BT  FLAG 
SVP  INDEX  FOR  2000  FT  DEPTH 
VELOCITY  FOR  DEPTH  PAIR  REALA4 


TYPE 

REALA4 
INIEGEEA2 
INTEGERA2 
INTEGER A  2 
INTEGERA2 
INTEGERA2 
REALA4 


RANGE 


•2  TO  +2 


1  OR  2 


C-5H.  I 


XBTERR 


1 7-Dec~ 1 934  15:41:30 
17- Dec-1 9 84  15:41:28 


tS  1 

0o59  1  REAL A4  DBT,UBT 

0060  1  INTEGERA2  IANS , ILYR , 1NBT , ISUP  ,  12000 

0061  1 

0062  1  COMMON  /GKt/  IANS  ,  ISUP  ,  ILYR  ,  12000  ,  INBT  ,  DBT  ( 25 ),  UBT  ( 25  ) 

0063  1 

0064  1  ! - END  GRF - 

0065  INCLUDE  'LOC. INC' 

0066  1  ! - LOC - 

0067  I  !  U  ARBL  SIZE  PURPOSE  1‘YPE  RANGE 

0068  1  !  - -  -  - 

0069  1  !  INDX  SSP  INDEX  INTEGERA2 

0070  1  1  LAT  (4)  LATITUDE  INTEGERA2 

0071  1  1  LONG  (4)  LONGITUDE  INTEGERA2 

0072  1  !  NM AREA  (20)  AREA  OCEAN  NAME  BYTE 

0073  1  '  NOC  NUMBER  OE  OCEAN  1NTEGERA2 

0074  1  !  RCZ  RANGE  TU  CUNUERG.  ZONE  REALA4 

0075  1 

0076  1  REALA4  RCZ 

0077  1  INTEGERA2  INDX , LAT , LONG  ,  NOC 

0078  1  BYTE  NM AREA ( 20 ) 

0079  1 

0080  1  COMMON  /LOC/  LAT ( 4 ) , LONG ( 4 ) , NOC , INDX , RCZ , NM ARE A 

0081  1 

0082  1  ! - END  LUC - 

0083  INCLUDE  'SUP. INC' 

0034  1  ! - SUP - 

'  \5  1  !  UARBL  SIZE  PURPOSE  TYPE  RANGE 

u  46  1  !  - -  -  -  - 

0087  1  !  BDE  BOTTOM  DEPTH  IN  FATHOMS  REALA4 

0088  1  !  BIOP  BIOLOGICAL  BACK  SCATTERING  COEF  REAL A4 

0089  1  !  ST0AIE  (9)  DATE  OE  LAST  BT  INPUT  BYTE 

0090  1  !  BTTIME  (Ei)  TIME  Of  LAST  BT  INPUT  BYTE 

0091  1  !  C  (50)  UELOCITY  (PAIRED  WITH  Z  FOR  SUP)  REALA4 

0092  1  !  CC  (50)  UELOCITY  (PAIRED  WITH  ZZ  FOR  SUP)REALA4 

0093  1  !  CS  SOUND  UELOCITY  AT  SURFACE  REALA4 

0094  1  !  DEG  TEMPERATURE  (DEG)  REALA4  57.2957795 

0095  1  !  EL  LAYER  DEPTH  DATA 

0096  1  !  F  FREQUENCY  KEALA4 

0097  1  !  GRDS  GRIDS  REALA4  0.0164 

0098  1  !  ITO  MINIMAL  2-WAY  TKAUEL  TIME  INTEGERA2 

0099  1  !  MGSOP  MGS  PR0U1NCE  NUMBER  INTEGERA2 

0100  1  !  N  t  OE  DEPTH/VELOCITY  PAIRS  1NTEGERA2 

0101  1  !  NN  *  OF  DEPTH/VELOCITY  PAIRS  1NTEGERA2 

0102  1  !  PI  MATHEMATICAL  CONSTANT  PI  REALA4  3.1415927 

0103  1  !  SNDATE  (9)  DATE  SYS  FARMS  LAST  UPDATED  BYTE 

0104  1  !  SNTIME  (8)  TIME  SYS  FARMS  LAST  UPPTAED  BYTE 

0105  1  !  SYDATE  (9)  CURRENT  DATE  READ  FROM  SYSTEM  BYTE 

0106  1  !  SYTIME  (8)  CURRENT  TIME  READ  FROM  SYSTEM  BYTE 

0107  1  !  'IMP  TEMPERATURE  REALA4 

0108  1  !  UMKZ  BOTTOM  BACK  SCATTERING  COEF.  KEALA4  -28.0 

0109  1  !  US  WIND  SPEED  BEALA4 

0110  1  !  1  (50)  DEPTH  Of  POINT  Of  SOUND  SPEED  REALA4 

0111  1  !  ZZ  (50)  DEPTH  OF  POINT  OF  SOUND  SPEED  REALA4 

'  )2  1 

0*13  1  INTEGERA2  ITO , MGSOP , N , NN 

0114  1  REALA4  BDF , B IOP , C ( 50 > , CC ( 50 ) , CS , DEG , EL , F , GRDS 


C-sV.i 


XBTERR 


17-Dec-1984  15:41:30 
1  7-Dec- 1 38  4  15:41:28 


*5  1 

v.  /&  1 

0117  1 

0118  1 
0119  1 

0120  1 
0121  1 
0122  1 
0123  1 

0124  1 

0125 
0126  1 
0127  1 

0128  1 
0129  1 

0130  1 

0131  1 

0132  1 

0133  1 

0134  1 

0135  1 

0136  1 

0137  1 

0138  1 

0139  1 

0140  1 

0141  1 

0144 

0145 

0146 

0147 

0143 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 

0161 

0162 

0163 

0164 

0165 

0166 

0167 

0168 

0’\9 

C  Jo 

0171 


REALA4  PI,TMP,UMKZ,WS,Z(50) ,ZZ(50) 

BYTE  SYDATE ( 9 ) , BYT  IME ( 8 ) , BTDATE ( 9 ) , BIT 1ME  <  8 ) 

BYTE  SNDATE ( 9 ) ,SNTIME(8) 

DATA  R 1 , DEG , GRDS/3 .1415927 , 57 . 2957795 ,0.0164/ 

DATA  UMKZ/-28 ..  / 


COMMON  /SOP/  E , N , Z , C , EL , MGSOP ,  BDE  ,  US , CS , TMP , B 1GP  , 

1  UMK2 , P 1 , DEG , GRBS , I TO , ZZ , CC  ,  NN , 

2  S  YD  AT  EjSYTIME,  BTDATE,  BIT  IME  , SNDATE , SNT IME 

- SOP-END - 

INCLUDE  ' SOP  1 . INC ' 


OARBL  SIZE 


PURPOSE 


■SOFT 


TYPE  RANGE 


BUEEER  (224) 

DS  (30) 

J20 

NS 

NSN 

SLN1Y 

OS  (30) 


HISTORICAL  DATA  FILE  BUEEER 
HISTORICAL  DEPTH 
*  OE  DEEP  OCEAN  DEPTH/OEL  PAIRS 
TOTAL  #  OE  PAIRS  IN  HISTORICAL 
MONTH  NUMBER  (1=JAN.,ETC) 
SALINITY 

HISTORICAL  0ELQC1TY 


REALA4 
REALA  4 
1NTEGERA2 
INTEGERA2 
INTEGERA2  1  TO 
REALA4 
REALA4 


1  o 

J.  M 


REALA4  BUFFER, DS,SLNTY, OS 
INTEGERA2  J20,NSN,NS 

COMMON  /S0P1/  J20,BUEFER(224) , NSN , SLNTY , DS ( 30 ) ,0S(30) ,NS 
- END  S0P1 - 


OARBL  SIZE  PURPOSE 


TYPE  RANGE 


ERRBT 

HLYR 

I 

TERROR 

INDXH 

INSSP 

K 

KUP 

NBT 

NDLYR 

NEWBT 

NH  1ST 

N15 

SPDDIE 


BT  ERROR  FLAG 

HISTORICAL  LAYER  DEPTH 

LOOP  COUNTER 

METRIC  ERROR  FLAG 

INDEX  OF  POINT  INSERTED  IN  HIST- 

INPUT  SSP 

COUNTER 

MAX  OE  SOP  AT  1500'  AND  INPUTTED  * 

NUMBER  OE  BT  POINTS 

INDEX  OF  BT  LAYER  DEPTH 

OPERATOR  RESPONSE  TO  NEW  BT  PROMPT 

HISTORICAL  DATA  FLAG 

HISTORICAL  SOP  INDEX  AT  1500' 

SOUND  SPEED  DIFFERENCE  (BT  OS  HIST) 


REALA4 
REAL A4 
INTEGERA2 
INTEGERA2 
INTEGERA2 
TNTEGERA2 
INTEGERA2 
INTEGERA2 
INTEGERA2 
1NTEGERA2 
INTEGERA2 
INTEGERA2 
INTEGEKA2 
REALA4 


AAA  OAR  TABLES  NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMON  AAA 


INTEGERA2  1, TERROR, INDXH , INSSP , K , KUP , NBT , NDLYR , NEUBT , NH 1ST , N 15 
REALA4  ERRBT, HLYR, SPDDIE 


IE ( ERRBT . NE . 2 . )  THEN 
WRITE  (5,272) 

ELSE 

WRITE (5, 276) 

END  IE 
UR 1TE ( 5 , 290 ) 


-PROMPT  OPERATOR - 

I  ERROR  FLAG  NOT  2 
!  WRITE  ERROR  MESSAGE  AND 
!  ERROR  FLAG  IS  2 
!  WRITE  ERROR  MESSAGE 
!  END  IE  BLOCK 
!  WRITE  HISTORICAL  DATA 


c-sry.  3 


0222 
0223 
0224 
0225 
0^26 
C  77 
0228 


XBTERR 

'  S2 

CALL  INSERT(NS,DS,VS,1500. ,N15> 

K.  1 3 

KUP=MAX0(N15, INBT) 

0174 

DO  315  K=1 , KUP 

0175 

IF ( K . GT . 1NBT.QR.K.GT.N15)  GO 

0176 

IE(K.GT. INBT. AND. K.LE.N15) 

0177 

1 

WRITE (5, 310)  K , DS ( K ) , US ( K ) 

0178 

IF ( K  .  LE . INBT . AND . K . GT . N15 ) 

0179 

1 

WR  ITE (5,312)  K , DBT ( K ) , UBT ( K 

0180 

IFCK.LE. INBT. AND. K.LE.N15) 

0181 

1 

WRITE (5, 3 10)  K , DS ( K ) , US ( K ) , 

0182 

315 

CONTINUE 

0183 

IF ( ERRBT . NE . 2 . >  THEN 

0184 

WRITE (5, 316) 

0185 

ELSE 

0186 

318 

WRITE (5, 320) 

0187 

WRITE <5, 321 ) 

0188 

END  IE 

0189 

0190 

0191 

0192 

0193 

0194 

325 

| _ 

READ  (5,330)  NEWBT 

IF ( ERRBT. EQ.l . . AND . NEWBT . EQ . 2 ) 
IF ( ERRBT . EQ . 2 . . AND .NEWBT.EQ.3) 
IF (ERRBT. EQ.l. . OR . NEWBT . EQ  .  1 .  OR 

IF ( NEWBT . EQ . 2 )  THEN 

0195 

0196 

CALL  ICLR 

0197 

WRITE (5, 340) 

0198 

RE AD (5, 330)  INDX 

(V  99 

NBT-NNBT 

^  )o 

DU  342  1*1, NBT 

0201 

D  (  X )  -  D  D  (  I) 

0202 

T (  I ) =TT ( 1) 

0203 

342 

CONTINUE 

0204 

0205 

0206 

0207 

0208 

l 

CALL  METRIC< 1NSSP,B,T,NBT,Z,C 
GO  TO  400 

END  IF 

IF ( NEWBT . EQ . 4 )  THEN 

0209 

0210 

IF(NDLYB.NE.NBT. AND . NDLYR . NE  .  ! 

0211 

INBT*NDLYR+1 

0212 

NBT* INBT 

0213 

END  IF 

0214 

CALL  INSERT ( NS, DS, US, DBT (NBT) 

0215 

SPDD IF=UBT( NBT) -US ( INDXH) 

0216 

DO  350  1=1, NBT 

0217 

UBT( I)=UBT(I)-SPDDIF 

0218 

350 

CONTINUE 

0219 

END  IF  i 

0220 

CALL  AS  IS ( INBT, DBT, UBT) 

0221 

400 

RETURN  ! 

17-Dec-1984 

17-Dec-1984 


15:41:30 

15:41:28 


INSERT 
MAX  0E 
MAX  OF 
TO  318  ! 

>  INPUTTED 
WRITE  DATA 
<=  INPUTTED 
WRITE  DATA 


POINT  IN  SUP 
SOP  INDEX  AND 
SOP  INDEX 
SKIP  NEXT 
*,  <» 


AND 


IN 

IN 


BT 

BT 


1500'  SUP 


>  1500'  SUP 


?7? 

/  ft 

276 

280 


<=  INPUTTED  #  AND  1500'  SUP 
, DBT ( K  ) , UBT ( K  >  !  WRITE  DATA 


END  DO  LOOP 
ERROR  FLAG  NOT  2 
PROMPT  NEW  BT  OR 
ERROR  FLAG  IS  2 
PROMPT  NEW  BT  OR 
PROMPT  USE  BT  AS 
!  END  IF  BLOCK 
!  OPERATOR  RESPONSE 
NH I8T*1  !  USE  HISTORICAL 
NH IST= 1  !  USE  HISTORICAL 
.NEWBT.EQ.3)  GO  TO  400  ! 


HISTORICAL 


ADJUSTED 

IS 


DATA 


SSP 
SSP 
GO  TO 


EX  IT 


OPERATOR  WANTS  NEW  SSP  AREA- 
NEW  SSP  AREA 
CLEAR  SCREEN 
PROMPT  FOR  NEW  SSP  AREA 
NEW  BT  AREA 
NUMBER  OF  BT 
DO  FUR  NUMBER  OF  BT 
STORE  DEPTH 
STORE  TEMPERATURE 
END  DO  LOOP 
, SLNTY , US ( 1 ) , I ERROR)  !  METRIC 
!  GO  TO  RETURN 
!  END  IF  BLOCK 


CHECK  METHOD  OF  CORRECT  IDN- 

i 

1 


BT  TO  FIT  HISTORICAL 
!  IF  LAYER  <>  1ST  OR  LAST 
NUMBER  OF  POINTS  IN  BT 
NUMBER  OF  POINTS  IN  BI- 


FORCE 
)  THEN 
RESET 
RESET 
END  IF  BLOCK 

, INDXH  >  !  INSERT  PI  AT  LAST 
!  SOUND  SPEED  DIFFERENCE 
!  DO  FOR  NUMBER  OF  BT 
!  SUBTRACT  SS  DIFFERENCE 
!  END  DO  LOOP 
!  END  IF  BLOCK 
!  USE  BT  AS  IS 
!  RETURN  TO  CALLING  ROUTINE 


BT  PT 


FORMAT  STATEMENTS - 

F0RMAT(/1H0,15X, 'PROBABLE  ERROR  IN  X B T ' 

1/1 H  ,  10X , ' NEAR  SURFACE  WIRE  BREAK  USE  HISTORICAL  DATA') 
FQSMAT(/1H0,10X, 'PROBABLE  ERROR  IN  XBT ' ) 

F0RMAT(/1H0,10X, 'HISTORICAL  DATA ', T52 ,  ' XBT  DATA' 

1/1H  , Til, 'DEPTH' ,121, 'UEL' ,T50, 'DEPTH' ,T60, 'V£L'//> 


C  --S’  v.  H 


XBTERR 


17-Dec-'1984  15:41130 
17- Dec-1984  15:41:28 


So 

0231 

0232 

0233 

0234 

0235 

0236 

0237 

0238 

0239 

0240 

0241 

0242 

0243 

0244 

0245 

0246 

0247 

0248 

0249 

0250 

0251 

0252 

0253 


310  FORMAT ( 15, 2810.1, T40, 15, 2F10.1) 

312  FORMAT (140, 15 , 2F10 . 1 ) 

316  F0RMAT(/1H0,T30, 'RECOMMEND  NEW  XB'f  BE  TAKEN' 

1/1H  ,T25,'IF  NOT  HISTORICAL  DATA  WILL  BE  USED' 
2/1H  ,  T25 , 'NEAR  SUREACE  WIRE  BREAK  WILL  NOT  ALLOW' 
3/1H  ,  T  2  5  , 'DATA  TO  BE  ADJUSTED' 

4/1H  ,T25, '  INDICATE  YOUR  CHOICE' 

5/1H  ,  T  2  5  , ' 1  =  N  E  W  XBT  OR  EDIT  CURRENT  XBT  ' 
6/lH$,T25, '2=USE  HISTORICAL  SSP',T&0) 

320  FORMAT (/1HO,T20,' 1=NEW  XBT  OR  EDIT  CURRENT  XBT', 

1  T53 , ' ( RECOMMENDED )  '  / 

2  T20 , ' 2  =  NEW  SSP  AREA ', T53 ,'( RECOMMENDED )' / 

3  T20 , ' 3  =  USE  HISTORICAL  SSP ', T53 ,'( RECOMMENDED )' / 

4  T20 , ' 4  =  USE  HISTORICAL  DATA,  '/ 

5  T20 ,  '  USING  THE  LAYER  (IE  ANY)'/ 

6  T20 ,  '  ASSOCIATED  WITH  YOUR  BT  ') 

321  FORMAT ( T20 , '5  ■  USE  XBT  EXACTLY  AS  IS', 

1  T 5 3  ,  '  (NOT  RECOMMENDED  BECAUSE  ' 

2/T53 ,  '  THE  XBT  HAS  BEEN  REJECTED  ' 

3/T53,  'AND  MAY  PRODUCE  UNRELIABLE  ' 

4/T53, 'RESULTS' 

5///T20, 'ENTER  YOUR  CHOICE  ',T53,$) 

330  FORMAT (13) 

340  FORMAK'  ENTER  NEW  SSP  AREA',T50,$> 

END 


COMMAND  QUALIFIERS 

EORTRAN  /CHECK=ALL/LIST/SHOW=(  INCLUDE  ,  NOMAP )  CLAFLEIJRJXBTERE .  E77 

/CHECK* < BOUNDS, OVERFLOW, UNDERFLOW) 

/DEBUG* (NOSYMBOLS, TRACEBACK) 

/STAN  HARD*  (NOSYNTAX,  NOSOIJRCE,.  FORM) 

/SHOW* (NOPREPROCESSOR, INCLUDE , NOMAP ) 

/E77  /NOG_FLOAT ING  / 14  /OPTIMIZE  /WARNINGS  /NOD_L INES  /NQCRQSS_REFERENCE  /N 


COMPILATION  STATISTICS 


Run  Time: 
Elapsed  Time: 
Page  Faults: 
Dynamic  Memory: 


3.25  seconds 
11.37  seconds 
412 

158  pages 


c-sy.r 


0001 
0002 
>003 
0004 
0005 
0006 
0007 
0008 
0009 
0010 
0011 
0012 
0013 
0014 
0015 
0016  1 
0017  1 

0018  1 
0019  1 

0020  1 
0021  1 
0022  1 
0023  1 

0024  1 

0025  1 

0026  1 
0027  1 

0028  1 
0029  1 

>030  1 

0031  1 

0032  1 

0033 
0034  1 

0035  1 

0036  1 

0037  1 

0038  1 

0039  1 

0040  1 

0041  1 

0042  1 

0043  1 

0044  1 

0045  1 

0046  1 

0047  1 

0048  1 

0049  1 

0050  1 

0051  1 

0052 
0053  1 

0054  1 

0055  1 

0056  1 

1057  1 

0058  1 

0059  1 


SUBROUTINE  XBTGRF ( MONTH ) 

PROLOGUE : 

MODULE  NAME:  XBTGRF 

AUTHOR:  S.  LAFLEUR  &  W.  WACHTER,  CODE  3333,  NUSC/NLL 
DATE:  1982  &  12/83  (FORTRAN  77) 

FUNCTION:  SUBROUTINE  XBTGRF  ALLOWS  THE  OPERATOR  TO  PLOT 
ON  A  GRAPHICS  TERMINAL. 

INPUTS:  HARD  COPY  OPTION.  PARAMETERS  PASSED  IN. 
VARIABLES  IN  COMMONS. 

OUTPUTS:  CRT  PROMPTING  MESSAGES  TO  OPERATOR. 

MODULES  CALLED:  ICLR , INSERT , LAYER 
CALLED  BY:  XBT 

INCLUDE  'GRF.INC' 


GRF 


VARBL 

SIZE 

PURPOSE 

TYPE 

RANGE 

DBT 

(25) 

DEPTH  OF  DEPTH/VEL  PAIR 

REAL *4 

IANS 

PREDICTION  TYPE 

INTEGER*2 

-2  TO  +2 

ILYR 

INDEX  FOR  LAYER  DEPTH 

INTEGER*2 

INBT 

OPERATOR  ENTERED  #  OF  BT  POINTS 

INTEGER*2 

ISVP 

LATEST  OR  HISTORICAL  BT  FLAG 

INTEGERS 

1  OR  2 

12000 

SVP  INDEX  FOR  2000  FT  DEPTH 

INTEGERS 

VBT 

(25) 

VELOCITY  FOR  DEPTH  PAIR  REAL *4 

REAL *4 

REALM 

DBT, VBT 

INTEGER*2  IANS, ILYR, INBT , ISVP ,  1 2000 

COMMON  /GRF/  IANS , ISVP , ILYR,  1 2000 , INBT , DBT ( 2 5 )  , VBT ( 25 ) 

- END  GRF - 

INCLUDE  'OCEANS. INC' 


OCEANS 

VARBL  SIZE  PURPOSE  TYPE 

I OCEAN  ( 50 )  ARRAY  OF  NAMES  OF  OCEANS  DATA 

I NT EGER *2  I OCEAN 
DIMENSION  I OCEAN ( 50 ) 

DATA  I OCEAN/ ' NO ' , ' RT ' , ' H  ','PA','CI 

1  '  NO '  ,  '  RT  '  ,  '  H  '  ,  'AT'  ,  'LA'  ,  'NT'  ,  '  IC  , 

2  'ME' , 'DI ' , 'TE' , 'RR' , ' AN' , ' EA ' , 'N 

3  ’ IN' , 'DI ’ , ' AN’ , '  O' , 'CE' , ' AN' , ' 

4  'NO' , 'RW' , 'EG' , ' IA' , 'N  ' , ' SE ' , ' A  ', 

COMMON  /OCEANS/  I OCEAN 

END  OCEANS 

INCLUDE  ' SVP . INC ' 

- SVP - 

VARBL  SIZE  PURPOSE  TYPE  RANGE 


,  '  FI 
O'  , 
SE'  , 


,  'C 
CE'  , 
A  '  , 


,  ' OC '  ,  ' EA ’  ,  ' N 
AN'  , 


BDF 

BIOP 

BTDATE  (9) 
BTTIME  (8) 


BOTTOM  DEPTH  IN  FATHOMS  REAL *4 

BIOLOGICAL  BACK  SCATTERING  COEF  REAL *4 

DATE  OF  LAST  BT  INPUT  BYTE 

TIME  OF  LAST  BT  INPUT  BYTE 


C-S-r-l 


0060 

1 

i 

C 

(50) 

VELOCITY  (PAIRED  WITH  Z  FOR  SVP)  REAL *4 

0061 

1 

i 

cc 

(50) 

VELOCITY  (PAIRED  WITH  ZZ  FOR  SVP) REAL *4 

JD062 

1 

i 

cs 

SOUND  VELOCITY  AT  SURFACE 

REAL *4 

0063 

1 

j 

DEG 

TEMPERATURE  (DEG) 

REAL *4 

0064 

1 

j 

EL 

LAYER  DEPTH 

DATA 

0065 

1 

i 

F 

FREQUENCY 

REAL *4 

0066 

1 

j 

GRDS 

GRIDS 

REAL*4 

0067 

1 

j 

I  TO 

MINIMAL  2-WAY  TRAVEL  TIME 

INTEGER*2 

0068 

1 

i 

MGSOP 

MGS  PROVINCE  NUMBER 

INTEGER* 2 

0069 

1 

i 

N 

#  OF  DEPTH/VELOCITY  PAIRS 

INTEGER* 2 

0070 

1 

j 

NN 

#  OF  DEPTH/VELOCITY  PAIRS 

INTEGER* 2 

0071 

1 

i 

PI 

MATHEMATICAL  CONSTANT  PI 

REAL *4 

0072 

1 

j 

SNDATE 

(9) 

DATE  SYS  PARMS  LAST  UPDATED 

BYTE 

0073 

1 

j 

SNT  I  ME 

(8) 

TIME  SYS  PARMS  LAST  UPDTAED 

BYTE 

0074 

1 

i 

SYDATE 

(9) 

CURRENT  DATE  READ  FROM  SYSTEM 

BYTE 

0075 

1 

1 

SYTIME 

(8) 

CURRENT  TIME  READ  FROM  SYSTEM 

BYTE 

0076 

1 

1 

TMP 

TEMPERATURE 

REAL *4 

0077 

1 

j 

UMKZ 

BOTTOM  BACK  SCATTERING  COEF. 

REAL *4 

0078 

1 

1 

ws 

WIND  SPEED 

REAL *4 

0079 

1 

i 

z 

(50) 

DEPTH  OF  POINT  OF  SOUND  SPEED 

REAL *4 

0080 

1 

i 

zz 

(50) 

DEPTH  OF  POINT  OF  SOUND  SPEED 

REAL *4 

0081 

1 

0082 

1 

INTEGER 

*2  ITO, MGSOP, N,NN 

0083 

1 

REAL *4 

BDF , BIOP , C ( 50 ) ,CC( 50) ,CS,DEG, 

EL , F , GRDS 

0084 

1 

REAL *4 

PI , TMP , UMKZ , WS , Z ( 50 ) ,ZZ(50) 

0085 

1 

BYTE 

SYDATE ( 9 ) , SYTIME ( 8 ) , BTDATE ( 9 ) 

, BTT I ME ( 8 ) 

0086 

1 

BYTE 

SNDATE ( 9 ) , SNTIME ( 8 ) 

0087 

1 

DATA 

PI, DEG, GRDS/3. 1415927, 57. 2957795, 0.0164/ 

0088 

1 

DATA 

UMKZ/-28 . / 

)089 

1 

0090 

1 

COMMON 

/SVP/  F, N,Z,C, EL, MGSOP, BDF, WS,CS 

, TMP, BIOP, 

0091 

1 

1 

UMKZ, PI , DEG, GRDS, ITO, ZZ,CC,NN, 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 

0101 

0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 

0111 

0112 


1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 


57.2957795 

0.0164 

3.1415927 


-28.0 


VARBL  SIZE 

BUFFER  (224) 

DS  (30) 

J20 

NS 

NSN 

SLNTY 

VS  (30) 


S YD ATE , SYTIME , BTDATE , BTT I ME , SNDATE , SNT I ME 

- SVP-END - 

INCLUDE  ' SVP1 . INC ' 

- SVP1 - 

PURPOSE 


TYPE 


RANGE 


HISTORICAL  DATA  FILE  BUFFER  REAL *4 

HISTORICAL  DEPTH  REAL *4 

#  OF  DEEP  OCEAN  DEPTH/VEL  PAIRS  INTEGER* 2 
TOTAL  #  OF  PAIRS  IN  HISTORICAL  INTEGER* 2 
MONTH  NUMBER  (WAN.,  ETC)  INTEGER* 2 

SALINITY  REAL  *  4 

HISTORICAL  VELOCITY  REAL *4 


1  TO  12 


REAL *4  BUFFER, DS, SLNTY, VS 

INTEGER* 2  J 20, NSN, NS 

COMMON  /SVP1/  J20, BUFFER(224), NSN, SLNTY, DS(30) ,VS(30) , NS 

- END  svp! - 


INCLUDE  ' LOC . INC ' 


-LOC- 


0113 

1 

!  VARBL 

SIZE 

PURPOSE 

TYPE 

0114 

0115 

1 

1 

i 

!  INDX 

—  —  *" 

SSP  INDEX 

INTEGER* 2 

)ll6 

1 

!  LAT 

(4) 

LATITUDE 

INTEGER *2 

0117 

1 

!  LONG 

(4) 

LONGITUDE 

INTEGER* 2 

0118 

1 

!  NMAREA 

(20) 

AREA  OCEAN  NAME 

BYTE 

RANGE 


r-  5^-^ 


0119 
0120 
JD 1 2 1 
0122 
0123 
0124 
0125 
0126 
0127 
0128 
0129 


0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

)l75 

0176 

0177 


1 

1 

1 

1 

1 

1 

1 

1 

1 

1 


!  NOC 
!  RCZ 


NUMBER  OF  OCEAN  INTEGER* 2 

RANGE  TO  CONVERG.  ZONE  REAL *4 

REAL *4  RCZ 

INTEGER *2  I NDX , LAT , LONG , NOC 
BYTE  NMAREA( 20 ) 

COMMON  /LOC/  LAT { 4 ) , LONG ( 4 ) , NOC , I NDX , RCZ , NMAREA 


-END  LOC- 


0130 

!  VARBL 

SIZE 

PURPOSE 

TYPE 

0131 

i  —  - 

* 

— 

— 

0132 

!  DDLYR 

LAYER  DEPTH  FOR  SUBROUTINE  CALL 

REAL *4 

0133 

!  DTS 

(50) 

MONTHLY  HISTORICAL  DEPTH  FROM  BUFFER 

REAL*4 

0134 

!  ENVEL 

ENVELOPE  FACTOR 

REAL *4 

0135 

!  I 

COUNTER 

INTEGER* 2 

0136 

!  IC 

(50) 

VELOCITY  IN  RASTER  UNITS 

INTEGER* 2 

0137 

!  ICOPY 

NUMBER  OF  COPIES  DESIRED  BY  OPERATOR 

INTEGER*2 

0138 

!  IGTYPE 

DEEP  PROFILE  TYPE  BASED  ON  DEPTH 

INTEGER*2 

0139 

!  II 

COUNTER 

INTEGER* 2 

0140 

!  I ILYR 

LAYER  DEPTH  FOR  SUBROUTINE  CALL 

INTEGER* 2 

0141 

!  IZ 

(50) 

DEPTH  IN  RASTER  UNITS 

INTEGER* 2 

0142 

!  J 

COUNTER 

INTEGER* 2 

0143 

!  JJ 

FACTOR 

INTEGER* 2 

0144 

!  JNBT 

NUMBER  OF  BT 

INTEGER*2 

0145 

!  JVMIN 

MINIMUM  SOUND  SPEED  ON  GRAPHS 

INTEGER* 2 

0146 

!  JVMAX 

MAXIMUM  SOUND  SPEED  ON  GRAPHS 

INTEGER* 2 

0147 

!  K 

COUNTER 

INTEGER* 2 

)  148 

!  KNT 

COUNTER  FOR  ENVELOPE 

INTEGER* 2 

0149 

!  M 

POINTER  FOR  BUFFER  ARRAY 

INTEGER* 2 

0150 

!  MONTH 

MONTH  SPECIFIED  BY  OPERATOR 

INTEGER* 2 

0151 

!  NSNS 

(3) 

STORE  PREVIOUS, CURRENT,  &  NEXT  MONTH 

INTEGER* 2 

0152 

!  NSNl 

SEASON  OF  YEAR 

INTEGER* 2 

0153 

!  Nl 

NUMBER  OF  DEPTH/VEL  PAIRS 

INTEGER* 2 

0154 

!  RMONTH 

(12) 

NAMES  OF  MONTHS  ARRAY 

REAL *4 

0155 

!  SCHNLD 

SOUND  CHANNEL  LAYER  DEPTH 

REAL *4 

0156 

!  THEBD 

DEEP  PROFILE  GRAPH  TYPE 

REAL *4 

0157 

!  VMIN 

MINIMUM  SOUND  SPEED 

REAL *4 

0158 

!  VTS 

(50) 

MONTHLY  HISTORICAL  VELOCITY  FROM  BUFFER 

REAL *4 

0159 

!  XMAX 

GRAPHIC  BOUNDARIES  COORDS  X  AXIS  MAX 

REAL *4 

0160 

!  XMIN 

GRAPHIC  BOUNDARIES  COORDS  X  AXIS  MIN 

REAL *4 

0161 

!  XX 

(50) 

VELOCITY  IN  RASTER  UNITS 

REAL *4 

0162 

!  YMAX 

GRAPHIC  BOUNDARIES  COORDS  Y  AXIS  MAX 

REAL *4 

0163 

!  YMIN 

GRAPHIC  BOUNDARIES  COORDS  Y  AXIS  MIN 

REAL*4 

0164 

0165 

!  YY 

1 

(50) 

DEPTH  IN  RASTER  UNITS 

REAL *4 

0166 

!  ***  VARIABLES 

NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMONS  *** 

INTEGER*2  I , IC, ICOPY, IGTYPE , I I , I ILYR, IZ,J 
INTEGER* 2  J J , JNBT , JVMIN , J VMAX , K , KNT , M , MONTH , NSNS , NSNl , Nl 
REAL*4  DDLYR , DTS , ENVEL , RMONTH , SCHNLD , THEBD , VMIN 
REAL  *  4  VTS , XMAX , XMIN , XX , YMAX , YMIN , YY 

DIMENSION  IC(50),IZ(50), XX( 50 ) , YY( 50 ) 

DIMENSION  DTS { 50 ) , VTS ( 50 ) 

DIMENSION  RMONTH (12), NSNS ( 3 ) 

DATA  RMONTH  / ' JAN  ' , ' FEB  ' , ' MAR  ' , ' APR  ' , 

' MAY  ’ , ' JUN  ' , ’ JUL  ' , ' AUG  ' , 


RANGE 
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0178 
0179 
)D  18  0 
0181 
0182 
0183 
0184 
0185 
0186 
0187 
0188 
0189 
0190 
0191 
0192 
0193 
0194 
0195 
0196 
0197 
0198 
0199 
0200 
0201 
0202 
0203 
0204 
0205 
0206 
)207 
0208 
0209 
0210 
0211 
0212 
0213 
0214 
0215 
0216 
0217 
0218 
0219 
0220 
0221 
0222 
0223 
0224 
0225 
0226 
0227 
0228 
0229 
0230 
0231 
0232 
0233 
J234 
0235 
0236 


2 


'  SEP  ' , ' OCT  ' , ' NOV  ' , ' DEC  ' / 


CALL  ICLR 
NSNS { 1 ) =NSN-1 

IF(NSNS(1) .EQ.O)  NSNS ( 1 ) =12 
NSNS { 2 ) =NSN 
NSNS ( 3 ) =NSN+1 

IF (NSNS ( 3 ) . EQ . 13 )  NSNS(3)=1 


PRELIMINARIES - 

!  CLEAR  SCREEN 
!  PREVIOUS  MONTH 
l  START  OF  YEAR  FIX 
!  CURRENT  MONTH 
!  NEXT  MONTH 
!  END  OF  YEAR  FIX 


CALL  INI TT ( 3 ) 

CALL  SCREEN( 100,600,100, 400) 
XMIN=0 . 

XMAX=300 . 

YMIN=25000 . 

YMAX=0. 

CALL  UW I NDO  ( XM I N ,  XM AX ,  YM I N ,  YM AX ) 


INTITIALIZE  SCREEN - 

!  INITIALIZE  TEKTRONIX  4025 
!  DEFINE  BOUNDS  IN  RASTERS 
!  GRAPHIC  BOUNDARIES  COORDS 
!  GRAPHIC  BOUNDARIES  COORDS 
!  GRAPHIC  BOUNDARIES  COORDS 
!  GRAPHIC  BOUNDARIES  COORDS 
!  DEFINE  BOUNDS  IN  USER  UNITS 


- DRAW  BOXES - 

CALL  MOVEU(XMIN,YMIN)  !  MOVE  BEAM  TO  THESE  COORDS 

CALL  DRAWU ( XMAX , YM I N )  !  DRAW  VECTOR  TO  THESE  COORDS 

CALL  DRAWU (XMAX, (YMAX+1600. ) )  !  DRAW  VECTOR  TO  THESE  COORDS 

CALL  DRAWU(XMAX-XMAX/3. , (YMAX+1600. ) )  !  DRAW  VECTOR 

CALL  DRAWU ( XMAX-XMAX/3 . , YMIN)  !  DRAW  VECTOR  TO  THESE  COORDS 

CALL  MOVEU ( XMAX-XMAX/3. , (YMAX+1600. )) !  MOVE  BEAM  TO  COORDS 

CALL  DRAWU (XMAX-XMAX/3. *2. , (YMAX+1600. )) !  DRAW  VECTOR 

CALL  DRAWU ( XMAX-XMAX/3 . *2 . , YMIN) !  DRAW  VECTOR  TO  THESE  COORDS 

CALL  MOVEU (XMAX-XMAX/3.* 2. , (YMAX+1600. )) !  MOVE  BEAM 

CALL  DRAWU(XMIN, (YMAX+1600. ) )  !  DRAW  VECTOR  TO  THESE  COORDS 

CALL  DRAWU (XMIN, YMIN)  !  DRAW  VECTOR  TO  THESE  COORDS 


CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 


LABEL  BOXES 


SYMBOL (0,300,1, 14, 'D  E  P  T  H 
MOVEU(XMIN+50 . , YMAX-1400 . )  ! 
TEXT ( 4 , ' LAST '  )  ! 
MOVEU ( XMIN+13 0 . , YMAX-1400. )  ! 
TEXT ( 7 , ' CURRENT ’ )  ! 
MOVEU (XMIN+ 240. , YMAX-1400. ) ! 
TEXT(4 , 'NEXT' )  ! 
MOVEU (XMIN+30 . , YMAX-400 . )  ! 
TEXT(7, 'MONTH  [')  ! 
MOVEU(XMIN+60 ., YMAX-400 . )  ! 
I NUMBR ( NSNS ( 1 )  ,  2  )  ! 
MOVEU ( XMIN+7 0 . , YMAX-400. )  ! 
TEXT ( 1 , ' ] ’ )  ! 
MOVEU(XMIN+130 ., YMAX-400. )  ! 
TEXT ( 7 , ' MONTH  [ ' )  ! 
MOVEU(XMIN+163. , YMAX-400. )  ! 
I NUMBR ( NSNS ( 2 ) , 2 )  ! 
MOVEU (XMIN+ 171 ., YMAX-400 . )  ! 
TEXT ( 1 , ' ] ' )  ! 
MOVEU (XMIN+2 30 . , YMAX-400. )  ! 
TEXT ( 7 , ' MONTH  [ ' )  ! 
MOVEU(XMIN+263. , YMAX-400. )  ! 
I NUMBR ( NSNS ( 3 ) , 2 )  ! 
MOVEU(XMIN+271. , YMAX-400. )  ! 
TEXT ( 1 ,  '  ]  '  )  ! 
MOVEU ( XMIN- 30 . , YMAX+1550 . )  ! 


FT')  !  PLOT  WORDS 
MOVE  BEAM  TO  THESE  COORDS 
PLOT  STRING  TEXT 
MOVE  BEAM  TO  THESE  COORDS 
PLOT  STRING  TEXT 
MOVE  BEAM  TO  THESE  COORDS 
PLOT  STRING  TEXT 
MOVE  BEAM  TO  THESE  COORDS 
PLOT  STRING  TEXT 
MOVE  BEAM  TO  THESE  COORDS 
CONVERT  INTEGER*2  TO  ASCII 
MOVE  BEAM  TO  THESE  COORDS 
PLOT  STRING  TEXT 
MOVE  BEAM  TO  THESE  COORDS 
PLOT  STRING  TEXT 
MOVE  BEAM  TO  THESE  COORDS 
CONVERT  INTEGER* 2  TO  ASCII 
MOVE  BEAM  TO  THESE  COORDS 
PLOT  STRING  TEXT 
MOVE  BEAM  TO  THESE  COORDS 
PLOT  STRING  TEXT 
MOVE  BEAM  TO  THESE  COORDS 
CONVERT  INTEGER* 2  TO  ASCII 
MOVE  BEAM  TO  THESE  COORDS 
PLOT  STRING  TEXT 
MOVE  BEAM  TO  THESE  COORDS 
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0237  CALL  TEXT ( 1 , ’ 0 ' )  !  PLOT  STRING  TEXT 

0238  CALL  MOVEU(XMIN-30 .  , 13000 . )  !  MOVE  BEAM  TO  THESE  COORDS 

1)239  CALL  TEXT(4,  '  1000  '  )  !  PLOT  STRING  TEXT 

0240  CALL  MOVEU{XMIN-30 . ,YMIN)  !  MOVE  BEAM  TO  THESE  COORDS 

0241  CALL  TEXT ( 4 , '2000' )  !  PLOT  STRING  TEXT 

0242  CALL  MOVEU ( XM I N+ 5 0 . , YMIN+1000 . )  !  MOVE  BEAM  TO  THESE  COORDS 

0243  CALL  TEXT ( 3 , RMONTH ( NSNS ( 1 ) ) )  !  PLOT  STRING  TEXT 

0244  CALL  MOVEU (XMIN+ 150 .  , YMIN+1000 .) !  MOVE  BEAM  TO  THESE  COORDS 

0245  CALL  TEXT ( 3 , RMONTH (NSNS ( 2 )) )  !  PLOT  STRING  TEXT 

0246  CALL  MOVEU (XMIN+2 50 YMIN+1000 .) !  MOVE  BEAM  TO  THESE  COORDS 

0247  CALL  TEXT ( 3 , RMONTH ( NSNS ( 3 )) )  !  PLOT  STRING  TEXT 

0248  CALL  MOVEU (XMIN+50 . , YMIN+3000 . )  !  MOVE  BEAM  TO  THESE  COORDS 

0249  IF(NOC.EQ.l)  CALL  TEXT ( 20 f IOCEAN)  !  DISPLAY  NPAC  OCEAN 

0250  IF(NOC.EQ. 2)  CALL  TEXT ( 20 , IOCEAN( 11 ) )  !  DISPLAY  NLANT  OCEAN 

0251  I F { NOC . EQ . 3 )  CALL  TEXT ( 20 , IOCEAN( 21 ) )  !  DISPLAY  MED  SEA 

0252  I F ( NOC . EQ . 4 )  CALL  TEXT ( 20 , IOCEAN( 31 ) )  !  DISPLAY  INDIAN  OCEAN 

0253  I F ( NOC . EQ . 5 )  CALL  TEXT (20,1 OCEAN (41))  !  DISPLAY  NORWEGIAN  SEA 

0254  CALL  MOVEU (XMIN+2 2 6 YMIN+3000 .) !  MOVE  BEAM  TO  THESE  COORDS 

0255  CALL  TEXT(9,'SSP  AREA:')  !  PLOT  STRING  TEXT 

0256  CALL  MOVEU (XMIN+2 98 .  , YMIN+3000 .) !  MOVE  BEAM  TO  THESE  COORDS 

0257  CALL  INUMBR( INDX , 2 )  !  DISPLAY  SSP  INDEX  # 

0258  CALL  MOVEU(XMIN+50 . , YMIN+4000 . )  !  MOVE  BEAM  TO  THESE  COORDS 

0259  CALL  TEXT(38,'***  RAW  BT  DATA  IS  SHOWN  WITH  X’’S  ***')  !  PLOT 

0260  CALL  MOVEU (XMIN+2 5 . , YMIN+5000 . )  !  MOVE  BEAM  TO  THESE  COORDS 

0261  CALL  TEXT  !  PLOT  STRING  TEXT 

0262  1  (53,'***  HISTORICAL  SSP  DATA  IS  SHOWN  WITH  SOLID  LINES  ***•) 

0263  11=1  !  INITIALIZE  COUNTER 

0264 

0265  ! - DRAW  WITHIN  BOUNDARIES - 

J 2 6 6  DO  777  MONTH=100 ,434,167  !  DO  FOR  GRAPHIC  AREA 

0267  CALL  UNCLIP  !  DISABLE  CLIPPING  BY  DRAW 

0268  I F ( MONTH . EQ .100) CALL  CLI P ( 100 , 266 , 100 , 400 )  !  DEFINE  CLIP  - 

0269  I F ( MONTH . EQ .267) CALL  CLIP ( 266 , 432 , 100 , 400 )  !  DRAW  NO  LINES 

0270  I F ( MONTH . EQ ,434) CALL  CLIP( 432 , 600 , 100 , 400 )  !  OUTSIDE  CLIP 

0271  NSNl=NSNS (II)  !  SEASON  NUMBER 

0272  11=11+1  !  INCREMENT  COUNTER 

0273 

0274  ! - t - EXTRACT  THE  MONTHLY  HISTORICAL  D 

0275  M= ( NSN1-1 ) *14+1  !  POINTER  FOR  BUFFER  ARRAY 

0276  DO  110  J-1,7  !  DO  FOR  1  TO  7 

0277  DTS ( J ) =BUFFER ( M )  !  DEPTH  FROM  BUFFER 

0278  VTS ( J ) =BUFFER ( M+ 1 )  !  VELOCITY  FROM  BUFFER 

0279  I F ( J . GT . 1 . AND . DTS ( J ) . LE . 1 . )  GO  TO  120  !  NEGATIVE  DEPTH 

0280  M=M+2  !  INCREASE  POINTER  VALUE 

0281  110  CONTINUE  !  END  DO  LOOP 

0282  J=8  !  SET  J  FOR  NEXT  DO  LOOP 

0283  120  N1=J20+J-1  !  NUMBER  OF  DEPTH/VEL  PAIRS 

0284  M=169  !  POINTER  FOR  BUFFER  ARRAY 

0285  DO  130  K=J,N1  !  DO  FROM  8  TO  #  OF  PAIRS 

0286  DTS(K) =BUFFER(M)  !  DEPTH  FROM  BUFFER 

0287  VTS ( K ) =  BUFFER ( M+ 1 )  !  VELOCITY  FROM  BUFFER 

0288  M=M+2  !  INCREASE  POINTER  VALUE 

0289  130  CONTINUE  !  END  DO  LOOP 

0290 

0291  ! - DETERMINE  DEEP  PROFILE  GRAPH  TYPE  BY  TRUE  BOTTOM 

9292  THEBD=BDF*6 . 0  !  DEEP  PROFILE  GRAPH  TYPE 

J 293  IF(THEBD.GE.0. .AND. THEBD.LE. 12000. )  IGTYPE=1  !  TYPE  ONE 

0294  IF(THEBD. GT. 12000. .AND. THEBD.LE. 16000. )  IGTYPE=2<  TYPE  TWO 

0295  IF(THEBD.GT. 16000 . )  IGTYPE=3  !  TYPE  THREE 
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0296 

0297  ! - DETERMINE  THE  MINIMUM  SOUND  SPEED,  SOUND  CHANNEL  DEPTH 

X) 2 98  SCHNLD=10000  .  !  SOUND  CHANNEL  LAYER  DEPTH 

0299  VMIN=VTS ( 1 )  !  MINIMUM  SOUND  SPEED 

0300  CALL  LAYER ( N1 , DTS , VTS , DDLYR )  !  DEPTH  OF  SURFACE  DUCT  LAYER 

0301  CALL  INSERT (Nl, DTS, VTS, DDLYR, II LYR)  !  INSERT  POINT  INTO  SVP 

0302 

0303  DO  53  I = I ILYR+1 , N1  !  DO  FROM  LAYER  TO  #  OF  PAIRS 

0304  I F ( VTS ( I ) . LE . VTS ( I +1 ) . AND . SCHNLD . EQ . 10000 . ) 

0305  1  SCHNLD=DTS ( I )  !  SOUND  CHANNEL  LAYER  DEPTH 

0306  IF (VTS ( I ) . LT . VMIN ) VMIN=VTS ( I )  !  SET  MIN  VELOCITY 

0307  53  CONTINUE  !  END  DO  LOOP 

0308  JJ= { VMIN-10 . ) /50 .  !  FACTOR  FOR  JVMIN 

0309  JVMIN=50*JJ  !  MIN  VELOCITY 

0310  JVMAX=JVMIN+300  !  MAX  VELOCITY 

0311  KNT=1  !  SET  ENVELOPE  COUNTER 

0312 

0313  ! - CONVERT  Z'S  AND  C'S  TO  RASTER  UNITS  AND  DRAW  DE 

0314  200  DO  230  K=1,N1  !  DO  FOR  NUMBER  OF  PAIRS 

0315  XX (K) = . 64* ( VTS ( K ) -JVMI N ) +MONTH  !  . 64=RASTERS/ ( FT/SEC ) 

0316  _  YY(K) =343- ( . 14*DTS ( K) ) +37 .  !  343=RASTER  HT  OF  0*DEPTH 

0317  IC(K)=XX(K)  !  VELOCITY  IN  RASTERS 

0318  IZ(K)  =*YY(K)  !  DEPTH  IN  RASTERS 

0319  230  CONTINUE  !  END  DO  LOOP 

0320  CALL  CONECT(IC(l) ,IZ(1) ,IC(2) ,IZ(2))  !  DRAW  LINE 

0321  DO  240  M=3 ,Nl  !  #  OF  DEPTH/VEL  PAIRS 

0322  CALL  DRAW (IC(M),IZ(M))  !  DRAW  BEAM  WITHIN  CLIP 

0323  240  CONTINUE  !  END  DO  LOOP 

0324  DO  250  K=l,Nl  !  SET  UP  TO  DRAW  ENVELOPE 

) 3  2  5  ENVEL=15.-.006*DTS(K)  !  ENVELOPE 

0326  IF(KNT.LE.l)  THEN  !  FIRST  TIME  THROUGH 

0327  VTS(K)  =  VTS(K)  -  ENVEL  !  VELOCITY  ENVELOPE 

0328  ELSE  !  SECOND,  THIRD  TIME  THROUGH 

0329  VTS(K)  =  VTS(K)  +  2*ENVEL  !  VELOCITY  ENVELOPE 

0330  END  IF  !  END  IF  BLOCK 

0331  250  CONTINUE  !  END  DO  LOOP 

0332  KNT  =  KNT  +  1  !  INCREASE  COUNT 

0333  I F ( KNT . LE . 3 )  GO  TO  200  !  GO  BACK  FOR  2ND  AND  3RD  TIMES 

0334 

0335  ! - PLOT  THE  RAW  BT  DATA - 

0336  IF(INBT.GT.O)  THEN  !  IF  =  0  GO  TO  HARDCOPY  OPTION 

0337  DO  700  M=1,INBT  !  DO  FOR  #  OF  BTS 

0338  IF(DBT(M) .GT. 2000.0)  GO  TO  193  !  BOTTOM  DEPTH  >  2000' 

0339  XX(M) = . 64* (VBT(M) -JVMIN) +MONTH  !  . 64=RASTERS/(FT/SEC) 

0340  IC(M)=XX(M)  !  VELOCITY 

0341  YY(M)=343-( .14*DBT(M) )  +  37. !  343  =  RASTER  HT  OF  0 *DEPTH 

0342  IZ(M)=YY(M)  !  DEPTH 

0343  700  CONTINUE  !  END  DO  LOOP 

0344  193  JNBT=M-1  !  NUMBER  OF  BT 

0345  DO  194  K=l,2  !  DO  TWICE 

0346  CALL  SYMBOL((IC(K)-2), (IZ(K)-2) ,0,1, 'X' )  !  PLOT  WORDS 

0347  IF( INBT.EQ. 1)  GO  TO  777  !  FIRST  BT 

0348  194  CONTINUE  !  END  DO  LOOP 

0349  IF( JNBT.GE. 3 )  THEN  !  IF  MORE  THAN  OR  =  THREE 

0350  DO  195  M=3 , JNBT  !  DO  FOR  #  OF  BT 

0351  CALL  SYMBOL( ( IC(M)-2) ,( IZ(M)-2) ,0,1, 'X' )  !  PLOT  WORDS 

J352  195  CONTINUE  !  END  DO  LOOP 

0353  END  IF  !  END  IF 

0354  CALL  LNTYPE ( 2 )  !  LINE  TYPE  . 
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0355  CALL  CONECT ( IC(1) , IZ(1) , IC(2) , IZ(2) )  !  DRAW  LINE 

0356  DO  198  M=3,JNBT  !  DO  FOR  NUMBER  OF  BTS 

}357  CALL  DRAW (IC(M),IZ(M))  !  DRAW  BEAM  WITHIN  CLIP 

0358  198  CONTINUE  !  END  DO  LOOP 

0359  CALL  LNTYPE ( 1 )  !  LINE  TYPE  _ 

0360  END  IF  !  END  IF  BLOCK 

0361  777  CONTINUE  !  END  DO  LOOP 

0362  CALL  MOVE (0,0)  !  DUMMY  CALL  TO  DELAY  EXIT 

0363 

0364  ! - HARDCOPY  OPTION - 

0365  778  WRITE (5,780)  !  RING  BELL  FOR  ATTENTION 

0366  WRITE (5, 781)  !  ENTER  MONTH  PROMPT 

0367  READ (5, 78 7)  MONTH  !  OPERATOR'S  RESPONSE 

0368  I F ( MONTH . NE . NSNS ( 1 ) . AND. MONTH . NE . NSNS ( 2 ) . AND .MONTH . NE.NSNS ( 3 ) )GO 

0369  WRITE( 5,800)  !  NUMBER  OF  COPIES  QUERY 

0370  READ( 5,787)  ICOPY  !  #  OF  COPIES  NEEDED 

0371  IF( ICOPY.NE . 0 )  THEN  !  COPIES  WANTED 

0372  DO  900  1=1, ICOPY  !  DO  FOR  #  OF  COPIES 

0373  WRITE (5,1000)  !  PRINT  SCREEN  IMAGE 

0374  900  CONTINUE  !  END  DO  LOOP 

0375  _  END  IF  !  END  IF  BLOCK 

0376  CALL  UNCLIP  !  NO  CLIPPING 

0377  CALL  ICLR  !  CLEAR  SCREEN 

0378 

0379  ! - FORMAT  STATEMENTS - 

0380  780  FORMAT ( 1 0  0 ( / '  ! BEL ' ) ) 

0381  781  FORMAT ( 1H$ , '  ENTER  MONTH#  YOU  THINK  MATCHES  THE  XBT  BEST', 

0382  1  T60 , '  ') 

0383  787  FORMAT (12) 

)384  800  FORMAT (1H$,'  HOW  MANY  HARD  COPIES  WOULD  YOU  LIKE?  [ 0 , 1 , 2 , ETC . ] ' , 

J385  1  T60 , '  ') 

0386  1000  FORMATC  !HCO  S') 

0387 

0388  RETURN 

0389  END 
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SUBROUTINE  XBTMOD ( NBT , N I , N2 ,NDLYR) 

PROLOGUE : 

MODULE  NAME:  LYRMOD 

AUTHOR:  S.  LAFLEUR,  W.  WACHTER  (FORTRAN  77) 

DATE:  7/84  &  7/84  (FORTRAN  77) 

FUNCTION:  SUBROUTINE  XBTMOD  LIMITS  THE  XBT  SOUND  SPEEDS 
TO  THE  TOLERANCE  ENVELOPE  ABOUT  THE  HISTORICAL 
DATA.  IF  THE  LAST  PART  OF  THE  XBT  IS  OUT  OF 
TOLERANCE,  THESE  'NOUT'  POINTS  WILL  BE  DELETED. 

IF  THIS  CAUSES  THE  LAYER  DEPTH  POINT  TO  BE  DELETED, 

THE  LAST  GOOD  POINT  BECOMES  THE  NEW  LAYER  DEPTH. 

DURING  THE  SECOND  EXECUTION  OF  THIS  SUBROUTINE, 

THE  XBT  DATA  IS  EXTENDED  TO  2500  FEET  BY  CALLING  'AS I S'. 
INPUTS:  PARAMETERS  PASSED  IN  &  VARIABLES  IN  COMMONS. 

OUTPUTS:  MODIFY  SS  TO  STAY  WITHIN  TOLERANCE  ENVELOPE 
MODULES  CALLED:  AS IS 


!  CALLED  BY:  XBT 

I 

INCLUDE  ' DTV . INC ' 

1  j - DTV - 

1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

1  ! -  -  -  - 

1  !  D  (25)  DEPTH  REAL *4 

1  !  DD  (25)  DEPTH  REAL* 4 

1  !  NNBT  NUMBER  OF  BATHETHERMAL  INTEGER*2 

1  !  T  (25)  TEMPERATURE  REAL* 4 

1  !  TT  (25)  TEMPERATURE  REAL *4 

1  !  VEL  (25)  VELOCITY  REAL *4 

1  ! 

1  INTEGER* 2  NNBT 

1  REAL *4  D,DD,T,TT, VEL 

1 

1  COMMON  /DTV/  D( 25 ) , T ( 25 ) , VEL ( 25 ) , DD( 25 ) , TT ( 25 ) , NNBT 

1  j - END  DTV - 

INCLUDE  'SVP1.INC' 

1  ! - SVPl - 

1  !  VARBL  SIZE  PURPOSE  TYPE  RANGE 

1  j -  -  -  - 

1  !  BUFFER  (224)  HISTORICAL  DATA  FILE  BUFFER  REAL *4 

1  !  DS  (30)  HISTORICAL  DEPTH  REAL  *  4 

1  !  J20  #  OF  DEEP  OCEAN  DEPTH/VEL  PAIRS  INTEGER* 2 

1  !  NS  TOTAL  #  OF  PAIRS  IN  HISTORICAL  INTEGER* 2 

1  !  NSN  MONTH  NUMBER  (1=JAN., ETC)  INTEGER* 2  1  TO  12 

1  !  SLNTY  SALINITY  REAL *4 

1  !  VS  (30)  HISTORICAL  VELOCITY  REAL *4 

1 

1  REAL*4  BUFFER, DS, SLNTY, VS 

1  INTEGER* 2  J20 , NSN, NS 

1 

1  COMMON  /SVPl/  J20,BUFFER(224) , NSN, SLNTY, DS(30) , VS (30) , NS 

1  ! - END  SVPl - 


0054 

!  VARBL  SIZE 

PURPOSE 

TYPE 

0055 

i  - -  - 

• 

— 

0056 

1  DE 

DEPTH 

REAL *4 

057 

!  I 

LOOP  COUNTER 

INTEGER* 2 

0058 

!  K 

LOOP  COUNTER 

INTEGER* 2 

0059 

!  NBT 

NUMBER  OF  BT  POINTS 

INTEGER*2 

RANGE 


I 


0060 

0061 

J>062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 

0081 

0082 

0083 

0084 

0085 

0086 

0087 

0088 

)089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 

0101 


NDLYR 

BT  LAYER'S  POSITION  IN  ARRAY 

INTEGER *2 

NI 

#  OF  HISTORICAL  POINTS 

INTEGER* 2 

NOUT 

#  OF  POINTS  OUTSIDE  ENVELOPE 

INTEGER *2 

N2 

FLAG  FOR  SECOND  TIME  THRU 

INTEGER *2 

XX 

ENVELOPE  TOLERANCE  WIDTH 

REAL* 4 

***  VARIABLES  NOT  LISTED  HERE  SHOULD  APPEAR  IN  COMMONS  *** 


INTEGER* 2  I , K , NBT , NDLYR , NI , NOUT , N2 
REAL *4  DE,XX 


* 

NOUT=0 

DO  70  1=1, NBT 

IF(D(I) .GE.2500.) 

GO  TO 

DO  20  K=1 , NI 

I F ( DS { K ) . LE . D(  I ) 

.  AND .  D 

20 

CONTINUE 

K-NI 

30 

DE=VS(K)+( (VS(K+1) 

-VS (K) 

- PRELIMINARIES - 

!  INIT  #  POINTS  OUTSIDE  ENVELOPE 
!  DO  FOR  #  OF  BT  POINTS 
75  !  DEPTH  >  2500  FEET 

!  FOR  HISTORICAL  POINTS 
S(K+1) .GT.D(I) )  GO  TO  30  !  DEPTH 
!  END  DO  LOOP 
!  DEFINE  K 

)/(DS(K+l)-DS(K) ) )*(D( I)-DS(K) )  !  DEP 


i 


70 

75 

80 


XX=15 . - . 006*D( I ) 
IF(DE+XX.LT.VEL( I ) )  THEN 
VEL( I ) =DE+XX 
NOUT=NOUT+l 
ELSE 

I F ( DE-XX . GT . VEL ( I ) )  THEN 
VEL(I)=DE-XX 
NOUT=NOUT+l 
ELSE 
NOUT=0 
END  IF 
END  IF 
CONTINUE 
GO  TO  80 
NBT  =  1-1 

I F ( NOUT . GT . 0 . AND . NDLYR . GT . NBT 
NBT = NBT - NOUT 

IF(N2.EQ.O)  CALL  ASIS  ( NBT , D , 

RETURN 

END 


LIMIT  XBT  VELOCITIES  TO  ENVELOPE - 

ENVELOPE  WIDTH 
OUTSIDE  ENVELOPE 
RESET  VELOCITY 

INCREMENT  #  OUTSIDE  ENVELOPE 
INSIDE  ENVELOPE 
OUTSIDE  ENVELOPE 
RESET  VELOCITY 

INCREMENT  #  OUTSIDE  ENVELOPE 
INSIDE  ENVELOPE 
WITHIN  ENVELOPE 
END  IF  BLOCK 
END  IF  BLOCK 
END  DO  LOOP 
DO  NOT  RESET  #  OF  BT 
RESET  NUMBER  OF  BT 
-NOUT)  NDLYR=NBT-NOUT  !  RESET  NDLYR 
RESET  NUMBER  OF  BT  POINTS 
VEL)  !  IF  XBT  DATA  EXTEND  TO  2500' 
RETURN  TO  CALLING  ROUTINE 
END  SUBROUTINE 


